指定したフォルダへ出力する。
なお、ここでは同一名のファイルがある場合は出力日時と連番を記す。
＜サンプル＞
'実行時は深部のディレクトリを指定すること
'！！！場合によってはドライブ全体を抽出することになるので！！！
Const kaku As String = ".txt" '抽出する拡張子
Const goA As String = "A4" 'ディレクトリの最上層が書かれたセル位置
Const InGyo As Long = 4 '処理を始める行
Dim OutFile As Variant '書き込み先のアドレス
Dim FilePath As String '読み込み元のｱﾄﾞﾚｽ
Dim myFile() As String '出力先のファイル名を格納する
Dim myFileNo As Long
Dim myLink() As String '出力したことのあるｱﾄﾞﾚｽを格納する
Dim myLinkNo As Long
Dim myFlag As Boolean 'アドレスを取得しないかどうか 3-2-5に対応
Dim myDay As String
Sub 指定ディレクトリからファイルを取得する()
Dim R As Long, C As Long
Dim i As Long '処理を行っている階層の位置
Dim n As Long '処理を行っているフォルダ
Dim x As Long
ReDim Preserve myLink(0)
'0:出力する際のファイル名
myDay = Year(Date) & Month(Date) & Day(Date) & _
"_" & Hour(Time) & Minute(Time) & Second(Time)
'1：既に出力先となるファイル名があるか調べる
buf2 = Dir(OutFile & "\*" & kaku)
ReDim Preserve myFile(0)
Do While buf2 <> ""
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = buf2
'次のファイル名
buf2 = Dir()
Loop
'2：出力先を指定する
Dim objShell As Object, objFo As Object
Set objShell = CreateObject("Shell.Application")
Set objFo = objShell.BrowseForFolder(0, "出力するフォルダを選択して下さい", &H1, ROOT_FOLDER)
If objFo Is Nothing Then
'キャンセルされたので処理を中止する
Exit Sub
End If
OutFile = objFo.Items.Item.Path
'3：入力先を指定する
R = Range(goA).CurrentRegion.Rows.Count 'ディレクトリの数
C = Range(goA).CurrentRegion.Columns.Count '階層の深さ
'3-1:4行目のディレクトリを取得する
For i = 1 To C
'-1:パスを取得する
If FilePath = "" Then
'一番上の階層（読み込む位置は実質range("A4")
FilePath = Cells(4, i).Value
' ReDim Preserve myLink(0)
' myLink(1) = FilePath
ElseIf Cells(4, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(4, i).Value
End If
'-2:空白の場合はフォルダが存在しない
'→取得するファイルは存在しない
'∴ ループを抜ける
If Dir(FilePath, vbDirectory) = "" Then
Exit For
End If
'-3：出力したことのあるｱﾄﾞﾚｽはmyLinkへ格納する
Call チェックアドレス
If myFlag = True Then
'FilePathは出力したことのアドレスであるを示す
'∴ 処理しない
Else
'-4：取得したフォルダアドレスの中にあるファイルを、
'1で指定したアドレスへコピーする
ReDim Preserve myLink((UBound(myLink) + 1))
myLink(UBound(myLink)) = FilePath '出力したことのアドレスの履歴へ格納する
Call ファイルread
End If
Next i
FilePath = ""
'3-2:5行目以降の処理を行う
For n = 5 To 5 + R
'一旦、FilePathを空白にする
FilePath = ""
'浅い階層から深い階層へアドレスを読み進める
For i = 1 To C
'-1：変数ｘ = FilePathへ代入するｱﾄﾞﾚｽ（列数）
x = n '
If Cells(n, i).Value = "" Then
'空白の場合は上の列を読み込む(最大InGyo-1行目まで）
Do While Cells(x, i).Value = ""
If x = InGyo - 1 Then
'読み込み始めの行InGyoよりも上の行になったら処理を中止する
Exit Do
Else
x = x - 1
End If
Loop
Else
'空白でない場合はその値をFilePathへ
End If
'-2:パスを取得する
If FilePath = "" Then
'一番上の階層（読み込む位置は実質range("A4")
FilePath = Cells(x, i).Value
ElseIf Cells(x, i).Value <> "" Then
FilePath = FilePath & "\" & Cells(x, i).Value
End If
'-3:フォルダが存在するかどうか確認する
If Dir(FilePath, vbDirectory) = "" Then
'空白の場合はフォルダが存在しない
'→取得するファイルは存在しない
'∴ ループを抜ける
Exit For
End If
'-4：出力したことのアドレスか調べる
Call チェックアドレス
If myFlag = True Then
'FilePathは出力したことのアドレスであるを示す
'∴ 処理しない
Else
'-5:ファイル名を取得して、データをコピーする
ReDim Preserve myLink((UBound(myLink) + 1))
myLink(UBound(myLink)) = FilePath '出力したことのアドレスの履歴へ格納する
Call ファイルread
End If
Next i
FilePath = ""
Next n
myFileNo = 0
Set objShell = Nothing
Set objFo = Nothing
MsgBox "処理が完了しました"
End Sub
Private Sub チェックアドレス()
myFlag = False
myLinkNo = 0
Do While UBound(myLink) >= myLinkNo
If myLink(myLinkNo) = FilePath Then
'FilePathは出力したことのアドレスである
'→今回このｱﾄﾞﾚｽのデータは取得しない
'∴ ループを抜ける
myFlag = True
Exit Do
End If
'次のファイル名
myLinkNo = myLinkNo + 1
Loop
End Sub
Private Sub ファイルread()
'ファイル名を確認し、所定の場所にコピーする
Dim buf As String, buf2 As String
Dim NewFileName As String
Dim myC As Boolean
Dim i As Long
'出力元のファイル名を抽出する
buf = Dir(FilePath & "\*" & kaku) '拡張子（変数kaku）が.txtのファイルを抽出する
Do While buf <> ""
'出力先にあるファイル名と一致しているか探す
myC = False
For i = 1 To UBound(myFile)
If myFile(i) = buf Then
myC = True
Exit For
End If
Next i
'ファイルコピー開始
If myC = False Then
'新たなファイル名を出力
'FileCopy ｺﾋﾟｰ元のファイル名,コピー先のファイル名
FileCopy FilePath & "\" & buf, OutFile & "\" & buf
' 既存ファイル名を格納した変数myFileへ格納する
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = buf
Else
'重複するファイル名のため、名称を変更してコピーする
'ファイル名が既に存在する為、新しい名前を作成する（ファイル名_no）
NewFileName = Left(buf, InStr(buf, ".") - 1) '拡張子前までのファイル名
myFileNo = myFileNo + 1
FileCopy _
FilePath & "\" & buf, _
OutFile & "\" & NewFileName & "_" & myDay & "_" & myFileNo & kaku
'既存ファイル名を格納した変数myFileへ格納する
ReDim Preserve myFile(UBound(myFile) + 1) '値を残したまま配列を再設定する
myFile(UBound(myFile)) = NewFileName & "_" & myDay & "_" & myFileNo & kaku
End If
'次のファイル名を取得する
buf = Dir()
Loop
End Sub