Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

5572 / 76735

←次へ　｜　前へ→


	【76774】Re:複数のエクセルファイルから条件に一致する行のみを抽出したい

β - 15/3/11(水) 8:37 -


	引用なし

	パスワード

▼M さん：

とりあえず２つほど。

なお、
Const FolderPath As String = "C:\Users\140328\Desktop\新しいフォルダー"
これでは、このコードをMさんのPC以外で実行することができませんので
パスは動的に取得します。
また、サブフォルダからの抽出は不要のようですので、処理的に軽くて効率の良い
DIR関数によるファイル抽出にしました。

Test1は基本形というか、一行ごとにシート関数のMATCHを使ってチェック。
該当のものを、一行ずつ転記。

Test2は、効率を重視し、比較をDictionaryで行い、また、該当行もDictionaryに収めて
最後に一度でシートに書き込むタイプです。

このほかに、オートフィルターやフィルターオプションを使って処理する方法もありますね。

Sub Test1()
　　Dim FolderPath　As String
　　Dim fName As String
　　Dim shT As Worksheet
　　Dim shF As Worksheet
　　Dim z As Variant
　　Dim ckR As Range
　　Dim c As Range
　　Dim done As Boolean
　　
　　Application.ScreenUpdating = False
　　
　　'フォルダパスを動的に取得
　　FolderPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\新しいフォルダー\"
　　'または FolderPath = Environ("USERPROFILE") & "\DeskTOp\新しいフォルダ\"
　　
　　Set shT = ThisWorkbook.Sheets(2)
　　With ThisWorkbook.Sheets(1)
　　　　'指定番号領域
　　　　Set ckR = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　End With
　　'転記シートのクリア
　　shT.UsedRange.ClearContents
　　
　　'フォルダからエクセルブックを抽出
　　fName = Dir(FolderPath & "*.xls")
　　
　　Do While fName <> ""　　'抽出が終われば空白が返る。
　　
　　　　Set shF = Workbooks.Open(FolderPath & fName).Sheets(1)
　　　　'最初のデータブックからタイトル行をコピー
　　　　If Not done Then shF.Rows(1).Copy shT.Range("A1")
　　　　done = True
　　　　
　　　　For Each c In shF.Range("C2", shF.Range("C" & Rows.Count).End(xlUp))
　　　　　　'指定数字かどうか
　　　　　　z = Application.Match(c.Value, ckR, 0)
　　　　　　If IsNumeric(z) Then c.EntireRow.Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
　　　　Next
　　　　
　　　　shF.Parent.Close False
　　　　fName = Dir()　 '次のファイルを抽出
　　　　
　　Loop
　　
　　shT.Select
　　
End Sub

Sub Test2()
　　Dim FolderPath　As String
　　Dim fName As String
　　Dim shT As Worksheet
　　Dim shF As Worksheet
　　Dim z As Variant
　　Dim c As Range
　　Dim done As Boolean
　　Dim ck As Object
　　Dim dt As Object
　　Dim cols As Long
　　
　　Application.ScreenUpdating = False
　　
　　'フォルダパスを動的に取得
　　FolderPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\新しいフォルダー\"
　　'または FolderPath = Environ("USERPROFILE") & "\DeskTOp\新しいフォルダ\"
　　
　　Set ck = CreateObject("Scripting.Dictionary")
　　Set dt = CreateObject("Scripting.Dictionary")
　　
　　Set shT = ThisWorkbook.Sheets(2)
　　With ThisWorkbook.Sheets(1)
　　　　'指定番号をDictionaryに格納
　　　　For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
　　　　　　ck(c.Value) = True
　　　　Next
　　End With
　　'転記シートのクリア
　　shT.UsedRange.ClearContents
　　
　　'フォルダからエクセルブックを抽出
　　fName = Dir(FolderPath & "*.xls")
　　
　　Do While fName <> ""　　'抽出が終われば空白が返る。
　　
　　　　Set shF = Workbooks.Open(FolderPath & fName).Sheets(1)
　　　　'最初のデータブックからタイトル行をコピー
　　　　If Not done Then
　　　　　　With shF.Range("A1").CurrentRegion.Rows(1)
　　　　　　　　dt(dt.Count) = .Value
　　　　　　　　cols = .Columns.Count
　　　　　　　　done = True
　　　　　　End With
　　　　End If
　　　　
　　　　For Each c In shF.Range("C2", shF.Range("C" & Rows.Count).End(xlUp))
　　　　　　'指定数字ならコピー
　　　　　　If ck.exists(c.Value) Then dt(dt.Count) = c.EntireRow.Resize(, cols).Value
　　　　Next
　　　　
　　　　shF.Parent.Close False
　　　　fName = Dir()　 '次のファイルを抽出
　　　　
　　Loop
　　
　　'一括転記
　　shT.Range("A1").Resize(dt.Count, cols).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dt.items))
　　shT.Select
　　
End Sub

0 hits

▼

【76769】複数のエクセルファイルから条件に一致する行のみを抽出したい M 15/3/10(火) 21:23