| |
▼初心者 さん：
> 現在の状況は、集めてくるフォルダを探す。
> までの工程で止まっています。
どのようなコードになりましたか？
参考まで、FileSystemObjectを使うと、指定フォルダ直下の
サブフォルダ名を取得するコードは
以下のように簡単に書けます。
（注意）このマクロを走らせる前に、VBEメニュー[ツール]-[参照設定...]
で、
★ Microsoft Scripting Runtimeへの参照設定をしておいてください。
参照設定しなくとも 実行時に
CreateObject("Scripting.FileSystemObject") と実行時バインディング
すれば同様の処理ができますが、Fsoのもつ豊富なメソッド・プロパティを
簡単に参照するためにも、まずは事前バインディング法をおすすめします。
あと、
> Dim src As String: src = "E:\(Map2)"
> Dim Dest As String: Dest = "E:\(MapAll)\"
には コピー元フォルダ名、コピー先フォルダ名をそちらの環境のものに
変更しておいてください。（あ、Destはここでは不要でしたね）
Sub Try1() 'Debug.Print パス表示のみ
Dim src As String: src = "E:\(Map2)"
Dim Dest As String: Dest = "E:\(MapAll)\"
Dim FSO As FileSystemObject
Dim Folder As Folder
Set FSO = New FileSystemObject
For Each Folder In FSO.GetFolder(src).SubFolders
Debug.Print Folder.Path 'フォルダパス名を _
イミディエイト・ウィンドウに表示する
Next
Set FSO = Nothing
End Sub
イミディエイト・ウィンドウ（Ctrl+[G]で出てくるウィンドウ）に
ちゃんと、サブフォルダ名が表示されましたか？
>ちなみに、コピーで集約しようと思っています。
では、いよいよファイルのコピーに挑戦してみましょう。
以下のプロシージャで先頭の
> Dim SrcPath As String: SrcPath = "E:\(Map2)"
> Dim Dest As String: Dest = "E:\(MapAll)\"
のところを、そちらの環境のコピー元のパス、コピー先パス名
にそれぞれ変更してください。
★コピー先フォルダはすでに作成されているものとします。
以下の例では 拡張子が*.jpg のファイルのみをコピーしています。
Sub Try2copy() 'ワイルドカード使って <COPYFile> 1階層のみ
Dim SrcPath As String: SrcPath = "E:\(Map2)"
Dim Dest As String: Dest = "E:\(MapAll)\"
Dim Folder As Folder
Dim src As String
If Right$(Dest, 1) <> "\" Then Dest = Dest & "\"
With New FileSystemObject
For Each Folder In .GetFolder(SrcPath).SubFolders
src = Folder.Path & "\*.jpg" '拡張子*.jpgファイルのみ
Debug.Print src, Dest
On Error Resume Next
.CopyFile src, Dest
If Err().Number Then
Debug.Print , Err().Description
End If
On Error GoTo 0
Next
End With
End Sub
何らかの理由で Fso.CopyFileメソッドが失敗することがあります。
そのばあいは、イミディエイト・ウィンドウにエラーメッセージが
表示されます。（処理は継続します）
コピー先フォルダ名 Dest の末尾には "\"を付けて、コピー先が
フォルダ名であることを指定しています。
>サブフォルダは、名前は違うので問題はないかとは思います。
ファイル名に重複があると、FileCopy時にエラーになると思います。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
