| |
▼FSO初心者 さん：
>>>もしサブルーティン等のコードで、指定配下全サブ内含む全ファイルをコピーできるいいの書き方があればご教授いただければと思います。
>
>同名のファイルはないです。ただ、同名が出てきたら確かに厄介ですね。。ファイル名を変えてコピーとか厳しそうですね。
ファイル名に出現回数を付加してCopyしています。
CopyFile -> MoveFile ？
Sub CallFilePathListA()
Dim FSO As Object
Dim BeforePath As String 'コピー元フォルダパス
Dim AfterPath As String 'コピー先フォルダパス
Dim strF As String
Dim i As Long
strF = "*.XLS"
BeforePath = "D:\Excel\CopyA\" ' セルの値に変更してね。
AfterPath = "D:\Excel\CopyB\" ' セルの値に変更してね。
Set FSO = CreateObject("Scripting.FileSystemObject")
Call EnumFilePathListA(FSO, FSO.GetFolder(BeforePath), _
strF, AfterPath)
End Sub
Sub EnumFilePathListA(FSO As Object, objFolder As Object, _
strF As String, AfterPath As String)
Dim objfile As Object
Dim objSubDir As Object
Dim fNm As String
Dim pNm As String
Dim vfNm As Variant
Dim i As Long
'ファイル名を列挙
On Error Resume Next
For Each objfile In objFolder.Files
If UCase(objfile.Path) Like strF Then
fNm = Dir(AfterPath & objfile.Name)
If fNm <> "" Then ' 同名のファイル名
i = 0
vfNm = Split(objfile.Name, ".") '. で分解
pNm = vfNm(0)
Do
vfNm(0) = pNm & i ' ファイル名に数値を+
i = i + 1
fNm = Dir(AfterPath & Join(vfNm, ".")) ' 又同じか？
If fNm = "" Then ' 同じでなかったら
fNm = AfterPath & Join(vfNm, ".")
Exit Do
End If
Loop
FSO.CopyFile objfile.Path, AfterPath & fNm
' Debug.Print objfile.Path, AfterPath & fNm
Else
FSO.CopyFile objfile.Path, AfterPath & objfile.Name
' Debug.Print objfile.Path, AfterPath & objfile.Name
End If
End If
Next
'サブフォルダを検索
For Each objSubDir In objFolder.SubFolders
Call EnumFilePathListA(FSO, objSubDir, strF, AfterPath)
Next
End Sub
|
|
Yuki
- 12/8/25(土) 17:59 -
