| |
環境：Excel2010
はじめまして、マクロ初心者のhimawariと申します。
一覧表の項目名を含むファイルを検索し、
ファイルの内容を参照して、一覧表に反映するマクロを作っています。
マクロ実行の際は、ファイルを格納したフォルダを指定する仕組みです。
現時点では、指定フォルダ直下にファイルが存在する場合は正しく動作します。
今回改修により、指定フォルダのサブフォルダを含めてファイルを検索し、
動作するようにしたいです。
過去ログ等を読み、サブフォルダを含めたファイル検索は
FileSystemObject(FSO)やDir関数の再帰呼び出しを使用することは
理解したのですが、現行の仕組みにどう反映していいか応用ができません。
一覧表ありきの仕組みを想定して、一覧表にないファイルは無視という仕組みとしているためです。
添付するマクロをもとに、アドバイスを頂けたらと思います。
よろしくお願いいたします。
以下、イメージです
[一覧表]
No.1 とちおとめ
No.2 あまおう
No.3 ジョナゴールド
No.4 ふじ
[フォルダ構成]
果物フォルダ
-いちごフォルダ
-xxxxx_とちおとめ.xls
-xxxxx_あまおう.xls
-りんごフォルダ
-xxxxx_ジョナゴールド.xls
-xxxxx_ふじ.xls
[マクロ実行時]
1.一覧表の格納先を指定
2.個別ファイルの格納先を指定
3.実行
具体的には、果物フォルダにファイルがあれば動くマクロを、
いちごフォルダやりんごフォルダにファイルがある場合も動くようにしたいです。
不要そうなソースは削除してますが、情報が必要な場合は連絡ください。
Option Explicit
'一覧用の変数
Dim listBook As Workbook 'ワークブック
Dim listSheet As Worksheet 'ワークシート
Dim listPath As Variant '指定されたフォルダパス
Dim listFolderPath As String '格納先フォルダ
Dim listFileName As String 'ファイル名
Dim listRow As Long '一覧の行数
Dim listMaxRow As Long '一覧の最終行
Dim listColumn As Long '実績欄の開始列
Dim listColumn1 As Long '開始日列
'個票用の変数
Dim caseBook As Workbook 'ワークブック
Dim caseSheet As Worksheet 'ワークシート
Dim casePath As Variant '指定されたフォルダパス
Dim caseFolderPath As String '格納先フォルダ
Dim caseID As String 'フルーツ名
Dim caseFile As String 'フルーツ名より作成したファイル名
Dim caseFileName As String 'ファイル名
Dim buf As String 'ファイル名取得用変数
'その他もろもろ
Dim xlAPP As Application
Sub updateList()
listPath = Cells(15, 3).Value
listFolderPath = listPath & "\"
listFileName = listFolderPath & "\[一覧ファイル名].xls"
Set listBook = Application.Workbooks.Open(listFileName)
Set listSheet = listBook.Worksheets("[シート名]")
'最終行番号の取得
listMaxRow = Cells(Rows.Count, "B").End(xlUp).Row
'実績列番号の取得
listSheet.Activate
listColumn = Cells(1, 1).End(xlToRight).Column
listColumn1 = listColumn + 2
'（開始時）
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For listRow = 6 To listMaxRow
'個票を検索する
caseID = listSheet.Cells(listRow, 2)
casePath = Cells(16, 3).Value
caseFolderPath = casePath & "\"
caseFile = caseFolderPath & "*" & caseID & "*.xls?"
caseFileName = Dir(caseFile)
'存在しない場合
If caseFileName = "" Then
GoTo Continue
'存在する場合
Else
Set caseBook = Application.Workbooks.Open(caseFolderPath & caseFileName)
Set caseSheet = caseBook.Worksheets("[シート名]")
'反映
listSheet.Cells(listRow, listColumn1).Value = caseSheet.Cells(7, 33)
'テストケースを閉じる
caseBook.Close
Set caseBook = Nothing
End If
Continue:
Next listRow
listBook.Save
Set listBook = Nothing
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
