【VBA】同一ディレクトリ内のファイル名取得とA列

質問

【VBA】同一ディレクトリ内のファイル名取得とA列、B列のコピペ

A.xlsに同一ディレクトリ内にあるyyyymmdd.csvファイルを順に読み取り
A.xlsの
A1に対象ファイル名
B列に対象ファイル内のA列をコピペ
C列に対象ファイル内のB列をコピペ

次のファイルはD1
その次はG1
・
・

といった処理をさせたいです。
どのように記述すればよいでしょうか。

よろしくお願いしますm(._.)m

回答No.1

eden3616 · ベストアンサー

(1)A.xlsでAlt+F11よりVBEを開き、挿入から標準モジュールを作成
(2)最下のVBAコードを貼付て右上の「×」でVBEを閉じる
(3)Alt+F8より「Sample」マクロを実行

現在表示されているA.xlsの表示シートにご提示の仕様でデータがコピーされます。
（CSVファイルの名前に関係なく、A.xlsと同じフォルダにある全てのCSVファイルを対象とします）

■VBAコード
Sub Sample()
Dim buf As Variant, cnt As Integer, mySt As Worksheet
　　Set mySt = ActiveSheet: cnt = 1
　　'同一ディレクトリのcsvファイル一覧を取得
　　buf = Dir(ActiveWorkbook.Path & "\" & "*.csv")
　　'作画の停止
　　Application.ScreenUpdating = False
　　'CSVファイルの数だけ繰り返し
　　Do While buf <> ""
　　　　'CSVファイルを開き処理
　　　　With Workbooks.Open(buf)
　　　　　　'ファイル名を書出し
　　　　　　mySt.Cells(1, cnt) = .Name
　　　　　　'CSVファイルのA列をコピー
　　　　　　.Worksheets(1).Columns("A").Copy mySt.Cells(1, cnt).Offset(0, 1)
　　　　　　'CSVファイルのB列をコピー
　　　　　　.Worksheets(1).Columns("B").Copy mySt.Cells(1, cnt).Offset(0, 2)
　　　　　　'起点セルのオフセット
　　　　　　cnt = cnt + 3
　　　　　　buf = Dir()
　　　　　　'CSVファイルを閉じる
　　　　　　.Close
　　　　End With
　　Loop
　　'作画の開始
　　Application.ScreenUpdating = False
　　MsgBox "終了しました"
End Sub

補足

With Workbooks.Open(ActiveWorkbook.Path & ”¥” & buf)

上記のようにするとうまくできました！
ネットワークパスだったせいか
パスが長すぎたせいかわからかいですが…。

とても助かりました！
ありがとうございますm(._.)m

回答No.3

eden3616

Workbooks.openでファイル名のみを引数とした場合、カレントフォルダのファイルが参照されます。
ですが、カレントフォルダとしてA.xlsがあるフォルダを認識していないものと思われます。
CSVファイル名が取得されているため、ActiveWorkbook.PathでのA.xlsファイルのディレクトリパス取得は出来ているものと判断します。

ファイル名の指定ではなく、絶対パスでの指定に変更しましたので、ご確認お願いします。
Workbook.openの直前にDebug.PrintでCSVファイルのフルパスをイミディエイトウィンドウに書き出ししているため、再度エラーが有る場合は書き出されたパスがCSVファイルと一致しているか確認のうえ、補足願います。

■VBAコード
Sub Sample()
Dim buf As Variant, cnt As Integer, mySt As Worksheet, myDir As String
　　Set mySt = ActiveSheet: cnt = 1
　　myDir = ActiveWorkbook.Path & "\"
　　'同一ディレクトリのcsvファイル一覧を取得
　　buf = Dir(myDir & "\" & "*.csv")
　　'作画の停止
　　Application.ScreenUpdating = False
　　'CSVファイルの数だけ繰り返し
　　Do While buf <> ""
　　　　Debug.Print myDir & buf
　　　　'CSVファイルを開き処理
　　　　With Workbooks.Open(buf)
　　　　　　'ファイル名を書出し
　　　　　　mySt.Cells(1, cnt) = .Name
　　　　　　'CSVファイルのA列をコピー
　　　　　　.Worksheets(1).Columns("A").Copy mySt.Cells(1, cnt).Offset(0, 1)
　　　　　　'CSVファイルのB列をコピー
　　　　　　.Worksheets(1).Columns("B").Copy mySt.Cells(1, cnt).Offset(0, 2)
　　　　　　'起点セルのオフセット
　　　　　　cnt = cnt + 3
　　　　　　buf = Dir()
　　　　　　'CSVファイルを閉じる
　　　　　　.Close
　　　　End With
　　Loop
　　'作画の開始
　　Application.ScreenUpdating = True
　　MsgBox "終了しました"
End Sub

回答No.2

eden3616

No1のコードで訂正です
末尾のコードですが、以下の箇所の「False」を「True」にしてください。

　　'作画の開始
　　Application.ScreenUpdating = False

　　　　↓

　　'作画の開始
　　Application.ScreenUpdating = True

失礼しました。
仕様変更・不明な点があれば補足願います。

お礼

迅速な対応ありがとうございます！
試したところ、以下のエラーになりました。

---
『対象ファイル名』が見つかりません。
ファイル名およびファイルの保存場所が正しいかどうか確認してください。
---

対象ファイルがcsv形式であることが関係していたりしますか？？

マクロの記載されているエクセルと、対象ファイルは同一フォルダにあります。
デバッグで、buf変数内に格納された文字列と実際のファイル名が一致していることは確認できています。

よろしくお願いしますm(._.)m

補足

With Workbooks.Open(buf)

12行目の上記処理でエラーとなっています。
よろしくお願いしますm(._.)m