| |
▼おっさんそし さん：
>サブフォルダを含めるというところで躓いております。
サブフォルダを取得して、 各サブフォルダ名で GetDataを呼べばいいと
思います。
'引数は、フォルダーのパス
Private Sub GetData(ByVal FolderPath As String)
Dim FSO As New FileSystemObject
Dim Files As Files
Dim File As File
Dim myFolder As Folder
Dim Fol As Folder
Dim FileName As String
Dim TenkiRow As Integer
Dim ws As Worksheet
Application.ScreenUpdating = False
'引数のパス内のファイル一覧を取得
Set myFolder = FSO.GetFolder(FolderPath)
For Each File In myFolder.Files
'フルパスを取得
FileName = FolderPath & "\" & File.Name
'Debug.Print FileName
'ファイルを開く
Workbooks.Open FileName
Set ws = ActiveWorkbook.Worksheets(1)
With ThisWorkbook.Worksheets(1)
'転記先の行を取得
TenkiRow = .Range("B65536").End(xlUp).Offset(1).Row
'転記作業
.Range("A" & TenkiRow).Value = ws.Range("C1").Value
.Range("B" & TenkiRow).Value = ws.Range("M17").Value
.Range("C" & TenkiRow).Value = ws.Range("A9").Value
.Range("D" & TenkiRow).Value = ws.Range("F9").Value
.Range("E" & TenkiRow).Value = ws.Range("L2").Value
.Range("F" & TenkiRow).Value = ws.Range("C30").Value
End With
Set ws = Nothing
'ファイルを閉じる
ActiveWorkbook.Close False
Next
'-----------------------------------------------------------
For Each Fol In myFolder.SubFolders
GetData FolderPath & "\" & Fol.Name
Next
'-----------------------------------------------------------
Application.ScreenUpdating = True
End Sub
|
|
kanabun
- 14/2/13(木) 13:37 -
