Excel VBA質問箱 IV

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

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


1026 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【76769】複数のエクセルファイルから条件に一致す...
質問  M  - 15/3/10(火) 21:23 -

引用なし
パスワード
   特定のデータフォルダに複数のエクセルファイルデータがあり、それを一つのエクセルファイルに抽出する際に、今開いているエクセルファイルのシート1のA列に80個程度数値があり、その数値とデータファイルのC列が一致した場合のみ、データファイルの一致した行を抽出マクロを検討しています。
 以下のコードで組んでみたのですが、最初の一行しか抽出せずに、一行目に上書きされてしまいます。どのようにしたらよいのでしょうか。
良ければご意見お願いいたします。

Sub Sample()
Const FolderPath As String = "C:\Users\140328\Desktop\新しいフォルダー"
Dim objFSO As Object
Dim objBook As Object
Dim LastRow As Long
Dim i As Integer
Dim STRcsv As Variant
Dim kijun As Variant

Application.ScreenUpdating = False '画面のちらつき制御設定

Set objFSO = CreateObject("Scripting.FileSystemObject") 'FileSystemObjectを変数にセット

For Each objBook In objFSO.GetFolder(FolderPath).Files 'フォルダ内のファイル全て繰り返し処理
 
Workbooks.Open objBook.Path 'ファイルを開く

 LastRow = ActiveWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row '各シートのデータ(最終行+1)の取得
 
  For i = 1 To 750
  
   If ThisWorkbook.Sheets(1).Cells(i, 1) = ActiveWorkbook.Sheets(1).Cells(i, 3) Then
    ActiveWorkbook.Sheets(1).Rows(i).Copy ThisWorkbook.Sheets(2).Rows(i)
   Else
   
   End If
 
  Next i
 
 ActiveWorkbook.Close 'コピー後ファイルを閉じる
 
 Next

'オブジェクト変数解放
Set objFSO = Nothing

'画面のちらつき制御解除
Application.ScreenUpdating = True

End Sub

【76772】Re:複数のエクセルファイルから条件に一...
発言  β  - 15/3/11(水) 6:54 -

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

おはようございます

ちょっと整理させてください

・マクロブックの一番左側のシートのA列に数字が列挙されている
 たとえば

 A1 10
 A2 20
 A3 30

・フォルダ内に複数のデータブックがあって、その一番左側のシートの各行のC列に
 なにかしら数字がはいっている。それをマクロブック側で指定した数字(例では 10,20,30)
 と比較し、同じであれば、その行をマクロブックの左から2番目のシートに上詰めで転記する。

こういうことじゃないのですか?

現在のコードでは、マクロブック側のシートの 1行目とデータブックのシートの1行目、
2行目と2行目、3行目と3行目、それを比較して、マッチしたら、それをマクロブックの2番目のシートの
その行に転記、たとえば 1行目がマッチしたら1行目に転記。
かつ、どのデータブックに対しても、1行目がマッチしたら1行目に転記ですから上書き。

マッチングも適切ではありませんし、書き込み行も適切ではないですね?

追加で

・フォルダの中のサブフォルダからの抽出は考えなくていいですね?
・フォルダ側のデータブックのシートの1行目はタイトル行ですか?

【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

【76775】Re:複数のエクセルファイルから条件に一...
質問  M  - 15/3/11(水) 9:59 -

引用なし
パスワード
   ▼β さん:
ありがとうございます。
テスト1のコードを入力したら正常に動作しました。

当初の質問で"特定のデータフォルダに複数のエクセルファイルデータがあり"と書いていましたが、フォルダ内のファイルはCSVファイルでした。

エクセルファイルでは正常に動作したので、
fName = Dir(FolderPath & "*.xls")
の部分を"*.csv"に変更したところ
If IsNumeric(z) Then c.EntireRow.Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
の行に"Rangeメソッドは失敗しました。Worksheetオブジェクト"とのエラーが出ます。
申し訳ありませんが、csvファイルでも同様に判定し、抽出できるようにできないでしょうか。

【76776】Re:複数のエクセルファイルから条件に一...
発言  β  - 15/3/11(水) 10:21 -

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

こちらでフォルダ内のエクセルブックをCSVファイルにかえ、
コードも *.csv にかえて実行。
Test1、Test2 ともに正常に終了していますが?

不思議ですねぇ?

【76777】Re:複数のエクセルファイルから条件に一...
発言  β  - 15/3/11(水) 10:27 -

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

そちらの環境で、Test2ではどうなりますか?

【76778】Re:複数のエクセルファイルから条件に一...
お礼  M  - 15/3/11(水) 13:54 -

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

test2で確認したところ正常に動作しました。

非常に参考になり、問題も解決しました。ありがとうございます。

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