| |
▼ペンネーム船長 さん：
こんにちは〜
>やりたい事：各フォルダー（『A』『B』『Ｃ』・・・）の中のファイル名に『こんにちは』の文字の入ったエクセルをＣドライブ直下のtest2にコピーしたい。
>
> FSO.CopyFile "C:\test1\（フォルダー名）\*こんにちは*.xlsx", "C:\test2\"
一例ですが、
あるフォルダのなかにあるSubFolder は
Dirコマンドのオプションを指定すると取得できます。
'関数 DirFolder を呼び出し、SubFolderを取得し、
' イミディエイト・ウィンドウに表示する例
Sub Try1a()
Dim fData
Dim i&
Dim n&
n = DirFolder("C:\Test1", fData)
If n = 0 Then Exit Sub
For i = 1 To n
Debug.Print i; fData(i)
Next
End Sub
'関数 DirFolder を呼び出し、SubFolderを取得し、
'各サブフォルダ内の対象ファイルをコピーする例
Sub Try1b()
Dim fData
Dim i&
Dim n&
Dim Fso As Object
Const TOP_FOLDER = "C:\Test1"
Const COPY_TO = "C:\Test2"
n = DirFolder(TOP_FOLDER, fData)
If n = 0 Then Exit Sub
Set Fso = CreateObject("Scripting.FileSystemObject")
For i = 1 To n
On Error Resume Next
Fso.CopyFile fData(i) & "\*こんにちは*.xlsx", COPY_TO
If Err().Number Then
Debug.Print fData(i), Err().Description
Err().Clear
End If
On Error GoTo 0
Next
End Sub
'Dirコマンドのオプション
' /a:D フォルダ(Directory) 属性のみ検索
' /s SubDirも検索
' /b ファイル名のみ表示
Private Function DirFolder(Pathname As String, fData) As Long
Dim tmpPath As String
Dim sCmd As String
Dim ok As Long
tmpPath = Environ$("Temp") & "\Dir.tmp" '一時ファイルパス
sCmd = "DIR """ & Pathname & """ /a:D /s /b > """ & tmpPath & """"
ok = CreateObject("WScript.Shell") _
.Run("%ComSpec% /C " & sCmd, 7, True) 'Dirコマンド実行
If FileLen(tmpPath) > 0 Then
Dim buf() As Byte
Dim io As Integer
io = FreeFile()
Open tmpPath For Binary As io
ReDim buf(1 To LOF(io))
Get io, , buf
Close io
Kill tmpPath
fData = Split(vbCrLf & StrConv(buf, vbUnicode), vbCrLf)
DirFolder = UBound(fData) - 1
Else
DirFolder = 0
End If
End Function
|
|
kanabun
- 14/9/24(水) 12:08 -
