![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?5a7ff87)
お世話になっております。
VBA初級者です。
Excel VBA で任意のフォルダからサブフォルダまで再帰的に呼び出し、複数ファイルから作成日・名称・金額を複数行取得し、それぞれのファイル名も取得し、呼び出し元のブックの各行、各列に列挙していきたいと考えております。
今回、以下のコードでは呼び出し元ファイルと同じフォルダにある複数ファイルからデータをそれぞれ1行分のみ取得できます。どれもループが上手く働いておらず、困り果てております。
どのように修正すれば期待通りの動作を致しますでしょうか。何卒よろしくご教示下さいませ。
--
先日、『Excel VBA でFunctionが呼び出せません』のタイトルでこちらで相談させていただいた者です。
https://oshiete.goo.ne.jp/qa/11972550.html
せっかく皆様のアドバイスを頂いた上に、親切な方に詳細なコードを書いていただいたにもかかわらず私の実力ではコードを読み切れず、自分の集めてきたコードに戻りました。せっかくのご親切を無駄にしてしまい誠に申し訳ございません。
--------------------------------------------------------------
Dim buf As String, f As Object
Dim cnt As Long
Dim wFile As String
Dim wFilePath As String
Dim r As Long
'ボタンをクリックした時の処理
Public Sub sample()
cnt = 1
Call Subroutine("\\xxxxx\xxxxx\xxxxx")
'Excelファイルが存在していたらファイル名を返す
wFile = Dir(ActiveWorkbook.Path & "\■*.xlsm")
'先頭行を指定
r = 2
'カレントディレクトリに存在するExcelファイルを全て読み込む
Do While wFile <> ""
'開くExcelファイルのフルパスを取得
wFilePath = ActiveWorkbook.Path & "\" & wFile
'作成日・名称・金額を取得し配列に格納する(区切り文字:|)
strData = Split(File_Load(wFilePath), "|")
'作成日
Cells(r, 1) = strData(0)
'名称
Cells(r, 2) = strData(1)
'金額
Cells(r, 3) = strData(2)
'ファイル名
Cells(r, 4) = wFile
'次のExcelファイルを取得
wFile = Dir()
'行数をカウント
r = r + 1
Loop
End Sub
'Excelファイルを開いてデータを取得
'戻り値:作成日|名称|金額 ( | で区切る)
Function File_Load(ByVal wFilePath As String) As String
Dim CurBookName As Variant
Dim ColNo As Long
Dim RowNo As Long
Dim strValue As Variant
Dim FoundCell As Range
Dim i As Long
'ファイルを開く
Workbooks.Open wFilePath
'開いたExcelのファイル名を取得
CurBookName = Application.ActiveWorkbook.Name
'検索する項目を配列に格納
wItem = Array("作成日", "名称", "金額 (税込)")
'検索する
For i = LBound(wItem) To UBound(wItem)
If strValue = "*|*" Then
GoTo Continue ' Continue: の行へ処理を飛ばす
End If
Workbooks.Open wFilePath
Worksheets("ワークシート名").Activate
Set FoundCell = Worksheets("ワークシート名").Cells.Find(What:=wItem(i))
If FoundCell Is Nothing Then
'検索出来なかった場合
If i = 0 Then
strValue = ""
Else
strValue = strValue & "|"
End If
Else
'検索したセルに移動
FoundCell.Select
ColNo = ActiveCell.Column '列番号を取得
RowNo = ActiveCell.Row '行番号を取得
'作成日を取得する
If i = 0 Then
'最初の項目
strValue = Selection.Offset(RowNo + 1).Value
Else
'2番目以降の項目は|で区切る
strValue = strValue & "|" & Selection.Offset(RowNo + 1).Value
End If
End If
Next i
Continue:
'結果を返す
File_Load = strValue
'開いたExcelファイルを閉じる
Application.DisplayAlerts = False '確認メッセージの非表示
Workbooks(CurBookName).Close
Application.DisplayAlerts = True '確認メッセージの表示
End Function
Sub Subroutine(Path As String)
buf = Dir(Path & "\■*.xlsm")
Do While buf <> ""
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Subroutine(f.Path)
Next f
End With
End Sub
No.9ベストアンサー
- 回答日時:
#8
Option Explicit
Dim n As Long
Dim TargetFile()
Sub StartProgram()
Dim i As Long, ii As Long, j As Long
Dim FoundCell As Range
Dim strValue()
Dim wFile As String, wItem As Variant
Const filepath As String = "\\xxxxx\xxxxx\xxxxx"
On Error Resume Next
Erase TargetFile
n = 0
Call getFileList(filepath)
If UBound(TargetFile) < 0 Then Exit Sub
'検索する項目を配列に格納
wItem = Array("作成日", "名称", "金額 (税込)")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 0 To UBound(TargetFile)
ReDim strValue(200, UBound(wItem) + 1)
wFile = Mid(TargetFile(i), InStrRev(TargetFile(i), "\") + 1)
With Application.Workbooks.Open(TargetFile(i))
Worksheets("ワークシート名").Activate
For ii = LBound(wItem) To UBound(wItem)
'検索する
Set FoundCell = ActiveSheet.Cells.Find(What:=wItem(ii))
If FoundCell Is Nothing Then
'検索出来なかった場合
GoTo Continue
Else
'検索したセル
For j = 0 To ActiveSheet.Cells(Rows.Count, FoundCell.Column).End(xlUp).Row - FoundCell.Row
strValue(j, ii) = FoundCell.Offset(j + 1).Value
strValue(j, 3) = wFile
Next j
End If
Continue:
Next ii
.Save
.Close
End With
Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(strValue) + 1, 4) = strValue
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub getFileList(filepath)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim objFol As Object, objFile As Object
For Each objFol In FSO.GetFolder(filepath).SubFolders
Call getFileList(objFol.Path)
Next
For Each objFile In FSO.GetFolder(filepath).Files
If objFile.Name Like "■*.xlsm" Then
ReDim Preserve TargetFile(n)
TargetFile(n) = objFile.Path
n = n + 1
End If
Next
End Sub
引き続き詳細なコードをありがとうございます。
これはもう答えそのものになってますね、ありがとうございます!
今回はほぼこのままで使用させていただきたいと思います。
誠にありがとうございます。
先ほども述べましたが、ただただ感謝です。
No.8
- 回答日時:
こんばんは、、#2です。
>せっかくのご親切を無駄にしてしまい誠に申し訳ございません。
そんなことはありません。しっかり理解して使用する、とても良い事と思います。
(遊びで)くたくたで思考がほぼ停止ですが、
前回の再帰処理でファイル取得するコードで実行部分を追加したものを書きます。(一応最後まで書ききった方が分からなくても参考になるかも知れませんので)
このご質問の回答ではありませんので、参考まで
データを取得抽出する部分なんですが、2次配列にしてしまった関係で
手直しが必要かも知れません。
そのままでも動きますが、1シート200行のデータなので200を変えるか
配列の組み方を変えてください。
ReDim strValue(200, UBound(wItem) + 1)
検索キーワードは、項目タイトルにあってもなくても良いですが
一意である必要があります。(行、列はどこでも多分大丈夫)
ここまで書いて、やめようかと思いましたが、、コード書いたので、投稿します。
なぜでしょう?文字数オーバーでないのに投稿できない。。
続く
まず最初にご返答が遅れましたことお詫び申し上げます。
また励ましていただき非常に心強い気持ちになりました。
本当にありがとうございます。
お疲れのところ、詳細なコードまで頂き、感謝に堪えません。
No.7
- 回答日時:
以下、簡単な「再帰」の例として…
Option Explicit
Dim Fso As Object, recCell As Range
Const startFolder = "\\xxxxx\xxxxx\xxxxx" '指定フォルダ(トップフォルダ)
Const targetFile = "■*.xlsm" '対象とするファイルの識別名
Const targetSheet = "yyyyyyyyy" '対象とするシート名
Const wItem1 = "名前", wItem2 = "日付"
Sub main()
'準備(初期設定、シートクリア)
Set Fso = CreateObject("Scripting.FileSystemObject")
Set recCell = ThisWorkbook.Worksheets(1).Cells(1, 1)
recCell.Worksheet.Cells.Clear
'フォルダチェック―呼び出し
If Fso.FolderExists(startFolder) Then
Call FolderOUT(Fso.Getfolder(startFolder))
End If
recCell.Value = "--- END OF LIST ---"
End Sub
'*** フォルダ内出力処理(再帰)***
Sub FolderOUT(ByRef folder As Object)
Dim f As Object
'全サブフォルダを処理
For Each f In folder.SubFolders
Call FolderOUT(f)
Next f
'全ファイルを処理
For Each f In folder.files
If f.Name Like targetFile Then Call FileOUT(f)
Next f
End Sub
'*** 一ファイル分の出力処理 ***
'---適当に書き直してください
Sub FileOUT(ByRef file As Object)
Dim wb As Workbook
Dim cs As Range, c As Range
Application.ScreenUpdating = False
Set wb = Workbooks.Open(file.PATH)
On Error Resume Next
Set cs = wb.Worksheets(targetSheet).Cells
If Err = 0 Then
Set c = cs.Find(wItem1)
If Not c Is Nothing Then recCell.Value = c.Offset(1).Value
Set c = cs.Find(wItem2)
If Not c Is Nothing Then recCell.Offset(, 1).Value = c.Offset(1).Value
End If
On Error GoTo 0
recCell.Offset(, 2).Value = file.Name
Set recCell = recCell.Offset(1)
wb.Close False
Application.ScreenUpdating = True
End Sub
ご返答が遅れましたことをまずお詫びさせてください。
また、度々の詳細なコードをありがとうございます。
こちら参考にさせていただいております。
No.6
- 回答日時:
No3です
そのままを作ろうかと思ったのですが、補足を読んでも怪しいところが多々あるので、勝手に想定しました。(ほぼ前回の質問内容に沿ったものとして考えました)
https://oshiete.goo.ne.jp/qa/11972550.html
◇補足の怪しいところ(=取り出すセルの位置が不明)
・タイトルを検索するにしても、「名称」が二か所ありユニークではないので、どうするのか不明
・仮に検索できたとしても、その列の中のどのデータを引用するのか不明
ご提示のコードの
>Selection.Offset(RowNo + 1).Value
では、とんでもないところを参照している可能性が大と想像します。
・・・ってなわけで、以下のように勝手に解釈しました。
『指定フォルダ内にある(サブフォルダも含めて)全ての指定ファイル(=■*.xlsm 等:ただし必ずエクセルファイル)について、指定項目名(=ユニークであると仮定)を検索して、その直下のセルの値とファイル名を1行にして順にリストアップする』
・指定フォルダ、指定ファイル、検索項目名などは共通の定数としてまとめてあります。
・「再帰」がうまくできないことが、ご質問の大きな部分と思いますので、
再帰を実現する方法の一例として考えてください。
・リストは、VBAのあるブックの最初のシートに作成されます。
事前にシートをクリアしますのでご注意下さい。
・シート内の検索は、前回ご提示のFINDメソッドで行っていますので、完全一致では
ありませんのでご注意。 また、シート全体から検索はしていますが、FINDの場合、
A1セルはヒットしませんのでご注意。
(今回の補足を見ると、1行目から検索すれば充分そうな気がしますが、そのままにしてあります)
・何をなさりたいのかよくわからない部分のほとんどが、FileOUT(1ファイル分の出力)
の処理内容ですので、その部分は適宜書き換えてみてください。
・実際は、FileOUTの部分はFolderOUT内にに組入れても良いのですが、この方がわかり
やすそうなので分割してあります。
※ Dir関数は利用せず、FileSystemObjectのみの利用にしています。
また、全体の構成やロジックは、はなから作り直してあります。
※ 該当するファイルと同名のファイルが既に開いているか等のチェックは省いていますので、
実際の運用の際にはチェックを追加する必要があると思います。
(現状ではエラーになります)
※ ブックを「開く/閉じる」を繰り返すので、それなりの時間がかかることが予想されます。
ユーザに「〇%完了」などの表示を出す方が良いと思いますが省略しました。
※ 上記をいろいろ組み込んでも良いのですが、質問者様にはわかり難くなるだけと思いましたので…
■なぜか、この文章の後にコードを記載すると「投稿エラー」(文字数オーバーではない)になるので、すみませんが二回に分けて投稿します。
いつも詳細な解説をありがとうございます。
また、度々の示唆に富むご指導、誠に痛み入ります。
本当に感謝の言葉しかございません。
こちら参考にさせていただいております。
No.5
- 回答日時:
No.4です。
>'検索する項目を配列に格納
>wItem = Array("作成日", "名称", "金額 (税込)")
が横3列に繋がっているのなら、
Dim GetCell As Range 'プロシージャーの外(一番上で宣言している場所)
~
Set GetCell = FoundCell.Resize(,3)
で
GetCell.Copy Cells(r, 1)
でいけないかね?
For~NextやSplitとかなくして。
どの道取得したい値は同行なのだから1回検索すれば後は列の指定では?
と初級レベルは思います。
度々のご返答ありがとうございます。
>"作成日", "名称", "金額 (税込)"
につきましては、横3列につながっているわけではなく、少し飛び飛びになっておりました。
>と初級レベルは思います。
めぐみん_様で初級レベルでしたら、私は初級レベルを名乗れませんね…
No.4
- 回答日時:
No.1です。
他の疑問点としては
>'検索する項目を配列に格納
>wItem = Array("作成日", "名称", "金額 (税込)")
Bookによってそれほど該当する値のセル位置が変動するのでしょうか?
例えば『作成日』を基準としたら『名称』は何列目になるとかと書式の決まりがないのかなと。
あとDirをメインとサブで使っている点ってキチンと動作する物なのかな?
そう言う使い方の経験がないからちょっと不思議。
まずはご返答が遅れましたことお詫び申し上げます。
基本的には同様なものなのですが、以前使用していたバージョンのファイルも混在しておりまして、そちらが様々なフォーマットになっておりました。
Dirを二重に使うのはダメなようですね。ご指摘ありがとうございます。
No.2
- 回答日時:
こんばんは、
ポイントだけですが、示されている処理に
>複数行取得し
のループがあるように思えません。
ターゲットのファイルを開き、キーワードで検索してそのキーワードの
Selection.Offset(RowNo + 1).Value 1行下を取得して、次のキーワードに移行しているのではないでしょうか?
解決方法としては、色々考えられますが、取り敢えず置いといて
アドバイスとして、しっかり処理を分けて考えてみ置てください。
先ず、1ファイルを開いて検索する項目のすべてのデータを
シートに書き出すプロシージャを完成させる方が良いかも知れません。
この時、指定(定数)行から書き出すのでなく、
Cells(Rows.Count, 1).End(xlUp).Row + 1のような最終行下の新規行とすれば、このプロシージャを外部から開いたシートを対象に実行すれば、繰り返し使えます。
おそらく現在の目指す Functionかな、取り敢えず、単体で実行して直す事を勧めます。
同様に再帰的処理でしっかり条件に合うファイルのフルパスを取得する
プロシージャを書く、先のご質問のコードにあるようにシートなどに書き出し条件道理に抽出出来ているかを確認するなどしてはいかがでしょう。
両方が出来でば、アクティブなブックやシートを気を付け呼び出せば、完成かな。。
データ量が多い場合、処理速度などにも配慮が必要になると思います。
FSOよりDirを使った方が早いですし、
書き出しも都度 Cells(j, i) = FoundCell.Offset(j + 1).Value より、
配列を使い一度にした方が早いです。
strValue(j, i) = FoundCell.Offset(j + 1).Value
Cells(r, 1).Resize(UBound(strValue) + 1, 3) = strValue
明日早い為、この辺で
ご返答誠にありがとうございます。
1ファイルを開いてシートに書き出すプロシージャを作ってみました。
その後が上手く行っていないのですが、一歩進んだ感じです。
しかし、やはり理解が及んでいない部分が多く、難しいものですね。
No.1
- 回答日時:
何か前回の質問?で得られた回答が活かされてないように感じます。
どこを直せばと言うよりどうしてこうなったのか?不可解な点もありますし。
⇒ブックを開いたはずなのにループ内でまた(しかも何回も?)開いているのは何故なのか?とか。
ほぼ全てを書き直すにも元々どんなSheetからデータを集めているのか不明ですしね。
まずはご返答が遅くなりましたことをお詫び申し上げます。
エクスキューズにするわけではないのですが、初級者でして、完全にコピペプログラマとなっております。
ネットで聞きかじった知識を転用するのがやっとでどうしてこれが動いているのか?がはっきりとわからない状況です。
シートにつきましては補足説明で書かせて頂いきましたので、お時間があるようでしたらご覧下さいませ。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) Excel VBAどこが間違ってますか? 4 2023/07/17 10:04
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) フォルダの場所を可変にしたいです(マクロ) 4 2023/05/11 10:00
- Visual Basic(VBA) 【前回の続き続きです、ご教示ください】VBAの記述方法がわかりません。 2 2022/08/24 20:49
- Visual Basic(VBA) サブフォルダ(データ)にある複数の.xlsxファイルのSheet3のA2セルの値で01から左側をB2 2 2022/08/14 15:46
- Visual Basic(VBA) 貼り付けた値が消えていく 以下はソースファイルの2番目のシートのB6から最終行を取得 ターゲットファ 2 2023/07/27 12:23
- Visual Basic(VBA) 複数csvを横に追加していくマクロについて 2 2023/04/25 09:19
- その他(Microsoft Office) マクロVBAについて 1 2022/09/06 18:12
- Visual Basic(VBA) このVBAでExcelアプリケーションを作成は必要ですか? 3 2023/07/19 21:13
- Excel(エクセル) フォルダ内のワードファイルをPDFに一括変換するVBA 3 2023/06/09 16:51
関連するカテゴリからQ&Aを探す
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
VB6でUTF-8ファイルの読取りを
-
動かなくなってしまった古いVBA...
-
VB.net XMLの作成方法 Iniの代替
-
VBAでCSVファイルを読み込もう...
-
VBAの初心者でやりたいことがあ...
-
Excelファイルが存在するPC名が...
-
複数のワークブックのVBAを変更...
-
エクセルのVBAで開いている...
-
VBA ファイル名取得
-
EXCEL VBA tif画像のプロパティ...
-
フォルダ階層・ファイル名・ペ...
-
VBからExcelファイルを開くとき...
-
vbsでのアスタリスクとファイル...
-
Wordのプロパティ・総ページ数...
-
Excel97のVBAでコモンダイアロ...
-
vbaサブフォルダーをワイルドカ...
-
WSHでFD内のファイルを検索
-
Accessのハイパーリンクフィー...
-
excel マクロ PDF化の際のエラ...
-
【ACCESS VBA】アクセスからデ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
vbaサブフォルダーをワイルドカ...
-
動かなくなってしまった古いVBA...
-
ffftpでファイル取得が0バイト...
-
FileDialog オブジェクトでファ...
-
サブフォルダ含むフォルダ内の...
-
「エクセルファイルが開いてい...
-
Accessのウインドウサイズの固定
-
excel マクロ PDF化の際のエラ...
-
ExcelVBA 文字コード変換
-
AccessからOLEオブジェクト型の...
-
VBAでフォルダ内のhtmlファイル...
-
【VBAマクロ初心者】Excel VBA...
-
VBからExcelファイルを開くとき...
-
「AccessViolationException」...
-
【ACCESS VBA】アクセスからデ...
-
VB6でUTF-8ファイルの読取りを
-
ファイルを開く時間測定のスク...
-
複数のワークブックのVBAを変更...
-
VB.net XMLの作成方法 Iniの代替
-
エクセルのVBAで開いている...
おすすめ情報
インデントが効かず可読性の低いコードになっていることをお詫び申し上げます。
・呼び出し先はサブフォルダに散らばっている。
・呼び出し先はタイトルは同じもののフォーマットが異なるものが混在
・呼び出し元に複数の呼び出し先からデータを下記のように集計
呼び出し元
作成日 名称 金額 ファイル名
2020/10/10 株式会社○○ 550 ■○○.xlsm
2020/10/10 株式会社○○ 550 ■○○.xlsm
2020/10/10 株式会社○○ 550 ■○○.xlsm
呼び出し先(■*.xlsm)
NO. 名称 発注番号 発注作成日 名称 金額
1 申請 11-1a 2020/10/10 株式会社○○ 550
2 基礎 株式会社○○
3 その他 11-1a 2020/10/10 株式会社○○ 550
文字数制限からぶしつけな書きようになってしまいましたが、上記が関連ファイルの簡易的な図でございます。
皆様、ご返答が遅れましたことをまずお詫び申し上げます。
ここ3日ほど体調を崩しており、ご返答もままならない状態でした。
その間もご返答いただいており、申し訳ないやらありがたいやらで心底感謝しております。
今から精読させていただきたいと思いますので、改めて個別にご返答差し上げたいと思います。