Excel VBA質問箱 IV

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

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


5569 / 76732 ←次へ | 前へ→

【76774】Re:複数のエクセルファイルから条件に一致する行のみを抽出したい
発言  β  - 15/3/11(水) 8:37 -

引用なし
パスワード
   ▼M さん:

とりあえず2つほど。

なお、
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

1,193 hits

【76769】複数のエクセルファイルから条件に一致する行のみを抽出したい M 15/3/10(火) 21:23 質問[未読]
【76772】Re:複数のエクセルファイルから条件に一致... β 15/3/11(水) 6:54 発言[未読]
【76774】Re:複数のエクセルファイルから条件に一致... β 15/3/11(水) 8:37 発言[未読]
【76775】Re:複数のエクセルファイルから条件に一致... M 15/3/11(水) 9:59 質問[未読]
【76776】Re:複数のエクセルファイルから条件に一致... β 15/3/11(水) 10:21 発言[未読]
【76777】Re:複数のエクセルファイルから条件に一致... β 15/3/11(水) 10:27 発言[未読]
【76778】Re:複数のエクセルファイルから条件に一致... M 15/3/11(水) 13:54 お礼[未読]

5569 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free