[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ファルダ内（サブフォルダ含む）複数のブックからデータ抽出、一覧にするマクロ』（mik）
フォルダ内のすべての台帳ファイルから特定セルのデータを抽出して一覧ファイルを作りたいです。。
ファルダ内には、サブフォルダが何階層か存在して、その全てのフォルダの中にある台帳ファイルを対象にするマクロを作成したいのですが、、いろいろと調べましたが、初心者のわたしには難解でわかりませんでした・・同一フォルダ内だとなんとかできたのですが。。
台帳ファイル
→すべて同じフォーム (.xlsx)/ファイル名に統一性なし。
格納場所
→C:\台帳
※ファルダ内（サブフォルダ）には台帳ファイルしか存在しません。
やりたいこと
→各台帳ファイルのC2、C4、C5セルのデータと、できればファイルのパスも一覧として取得できたらいいなあと思っています。（一覧は見出しがあって、下方向にデータを抽出していきたいです）
もしマクロを教えていただける方がいましたら、どうかよろしくお願いします。
＜ 使用 Excel：Excel2010、使用 OS：unknown ＞
Sub test()
Dim p As String
Dim cmd As String
Dim s
Dim w()
Dim k As Long, n As Long
p = "C:\台帳\*.xlsx"
cmd = "cmd /c dir """ & p & """ /b/s/a-d"
s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
ReDim w(0 To UBound(s), 1 To 4)
w(n, 1) = "ファイル"
w(n, 2) = "C2"
w(n, 3) = "C4"
w(n, 4) = "C5"
Application.ScreenUpdating = False
For k = 0 To UBound(s) - 1
n = n + 1
With Workbooks.Open(s(k)).Sheets(1)
w(n, 1) = s(k)
w(n, 2) = .Range("C2").Value
w(n, 3) = .Range("C4").Value
w(n, 4) = .Range("C5").Value
.Parent.Close False
End With
Next
Worksheets.Add.Range("a1").Resize(n, 4).Value = w
End Sub
（マナ） 2020/09/26(土) 22:30
早々にありがとうございます。
希望通りの感じではあるのですが、、
一覧の抽出件数が、フォルダー内のデータ件数よりひとつ少ないのですが、、見出しのせいでしょうか？？
あと、実行する度にシートが作成されてしまいます。。
一覧のシートはひとつで、実行する度に更新されるみたいなイメージでできないでしょうか？
あとあと、台帳ファイルをひとつひとつ開かずに、セルデータを取得する方法とかはあるのでしょうか・・
すいません！
教えてもらう立場でいろいろと恐縮ですが、、
もしも、わかったらでよいので教えていただけると助かります。
教えていただいたマクロは、ひとつひとつしっかり勉強します！！
（mik） 2020/09/27(日) 00:55
（マナ） 2020/09/27(日) 07:50
ところで、結果は勿論間違いないんですが、
cmd = "cmd /c dir """ & p & """ /b/s/a-d"
s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
あたりは慣れないとむずかしそうですね。
今どきのひとはコマンドプロンプトなどは普通は使わないでしょうし。
dir /? とやって出力されるヘルプで、オプションの意味を調べる必要がありますね。
/b（ファイル名のみを表示します (見出しや要約が付きません)。）
/s (指定されたディレクトリおよびそのサブディレクトリのすべてのファイルを表示します。)
/a-d (フォルダは表示の対象外とします）
標準出力を受けてそれを一括して読み込むところとか。
私も、これはそういうものであると思ってやり過ごしていますが。
別のアプローチとして、FileSystemObjectを使って再帰処理に持ち込む方法もあるので、
質問者さん、余裕があれば調べてみられるとよいでしょう。
https://www.moug.net/tech/exvba/0060088.html
これの後半に参考になる部分がでてきます。
（γ） 2020/09/27(日) 08:33
台帳ファイルも、一覧もsheet1です。
実行する度に更新は、、そうです。上書きです。
（mik） 2020/09/27(日) 12:19
Sub test2()
Dim p As String
Dim cmd As String
Dim s
Dim w()
Dim k As Long
Dim wbn As String, wsn As String
p = "C:\台帳\*.xlsx"
cmd = "cmd /c dir """ & p & """ /b/s/a-d"
s = Split(CreateObject("wscript.shell").exec(cmd).stdout.readall, vbCrLf)
ReDim w(1 To UBound(s), 1 To 4)
For k = 0 To UBound(s) - 1
wbn = Dir(s(k))
wsn = "'" & Left(s(k), Len(s(k)) - Len(wbn)) & "[" & wbn & "]Sheet1'!"
w(k + 1, 1) = s(k)
w(k + 1, 2) = ExecuteExcel4Macro(wsn & "R2C3")
w(k + 1, 3) = ExecuteExcel4Macro(wsn & "R4C3")
w(k + 1, 4) = ExecuteExcel4Macro(wsn & "R5C3")
Next
With Worksheets("Sheet1").Range("a2")
.CurrentRegion.Offset(1).ClearContents
.Resize(k, UBound(w, 2)).Value = w
End With
End Sub
（マナ） 2020/09/27(日) 12:36
（マナ） 2020/09/27(日) 12:46
何か間違ってそうなので削除
（マナ） 2020/09/27(日) 17:46
Option Explicit
Dim fso As Object Dim w() Dim n As Long
Sub test() '実行するのはこれです
Dim p As String
p = "C:\台帳"
Set fso = CreateObject("scripting.filesystemobject")
n = 0
抽出 p
With Worksheets("sheet1")
.UsedRange.Offset(1).ClearContents
.Range("a2").Resize(n, UBound(w)).Value = Application.Transpose(w)
End With
Erase w
Set fso = Nothing
End Sub
Private Sub 抽出(p As String)
Dim f As Object, subF As Object
Dim wsn As String
For Each f In fso.getfolder(p).Files
If f.Name Like "*.xlsx" Then
n = n + 1
ReDim Preserve w(1 To 4, 1 To n)
wsn = "'" & p & "\[" & f.Name & "]Sheet1'!"
w(1, n) = f.Path
w(2, n) = ExecuteExcel4Macro(wsn & "R2C3")
w(3, n) = ExecuteExcel4Macro(wsn & "R4C3")
w(4, n) = ExecuteExcel4Macro(wsn & "R5C3")
End If
Next
For Each subF In fso.getfolder(p).subfolders
抽出 subF.Path
Next
End Sub
（マナ） 2020/09/27(日) 19:17
初心者でも扱い易いように、2通りのパターンを教えて頂きまして、ありがとうございます。
おかげ様で、希望通りの一覧リストが作成できましたー。
本当に感謝です。ありがとうございました。
教えて頂いたマクロは大切にします！
マクロの内容も理解できるように、今から、ひとつひとつ調べて勉強したいと思います。
（mik） 2020/09/27(日) 22:56
ありがとうございます。
内容が難しくて初心者のわたしにはついていけないのですが、、(；´Д｀)
コマンドプロンプト。。
FileSystemObject。。
いろんなアプローチの方法があるのですね。
リンクもありがとうございます！
今からFileSystemObjectについて勉強してみます！
まなさんが言っていた、FSOってやつですね！
（mik） 2020/09/27(日) 23:10
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.