| |
▼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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
