同一フォルダ内の複数ブックの特定の行を抽出し一覧

質問

あるフォルダにCSVファイルをエクセルに変換したファイルが大量にあります（60ファイルほど）。
ファイルを開くと同一形式で１行目には項目が入っており、２行目以下にデータが入っています。
マクロを実行することで、特定の列に数値が入力されている行だけを抽出し、一欄表の形に
したいと思います。

イメージは次のとおりで、例はD列に入っているパターンです。
出来ればメッセージボックスで列を指定できれば夢のようです。

[あるエクセルファイル]
　　　　　A　　　　　B　　　　　C　　　　　D
１　　　１００　　　　　１　　　　　
２　　　１００　　　　　１　　　　　１
３　　　１００　　　　　１　　　　　２
４　　　１００　　　　　１　　　　　３　　　３００

[別のエクセルファイル]
　　　　　A　　　　　B　　　　　C　　　　　D
１　　　２００　　　　　１　　　　　
２　　　２００　　　　　１　　　　　１
３　　　２００　　　　　１　　　　　２
４　　　２００　　　　　１　　　　　３　　　２００

マクロを実行するとメッセージボックスが出てきて、例えば４列目とかD列とか
指定をすると次のとおり一覧表ができる。

　　　　　A　　　　　B　　　　　C　　　　　D
１　　　１００　　　　　１　　　　　３　　　３００
２　　　２００　　　　　１　　　　　３　　　２００

初心者でどうにもならず、お力を借りるしだいです。
どうぞよろしくお願いいたします。

回答No.3

cj_mover · ベストアンサー

' ' ＝＝＝＝＝＝＝＝＝＝標準モジュール＝＝＝＝＝＝＝＝＝＝Re8303136
' ' 追加オーダー + 修正
Sub データ統合()
　　Const sExtention As String = ".xlsx"　　' ◆拡張子◆要指定！！(".xls" ? ".csv" ? ".xlsm" ? or ?)
　　Dim wshtNew As Worksheet
　　Dim sFullPath As String
　　Dim sEscName As String
　　Dim sF As String
　　Dim flg1st As Boolean
　　sFullPath = ThisWorkbook.Path & "\"
　　sEscName = ThisWorkbook.Name
　　sF = Dir(sFullPath & "*" & sExtention)
　　If sF = "" Then
　　　　MsgBox sFullPath & "　に　" & sExtention & "ファイル　は見つかりません"
　　　　Exit Sub
　　End If
　　Application.ScreenUpdating = False
　　Set wshtNew = Worksheets.Add
　　flg1st = True
　　Do While sF <> ""
　　　　If sF <> sEscName Then
　　　　　　Debug.Print sF
　　　　　　With Workbooks.Open(sFullPath & sF)
　　　　　　　　.Worksheets(1).Cells(2, 2).CurrentRegion.Copy _
　　　　　　　　　　　　　　Destination:=wshtNew.Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　　　　　　　.Close False
　　　　　　End With
　　　　　　flg1st = False
　　　　End If
　　　　sF = Dir()
　　Loop
　　With wshtNew
　　　　If flg1st Then
　　　　　　Application.DisplayAlerts = False
　　　　　　.Delete
　　　　　　Application.DisplayAlerts = True
　　　　　　Application.ScreenUpdating = True
　　　　　　MsgBox sFullPath & "　に　" & sExtention & "ファイル　は見つかりません"
　　　　Else
　　　　　　.Name = Format(Now, "yymmddhhmm")
　　　　　　With .UsedRange.Rows(0)
　　　　　　　　.Formula = "=""項目 ""&COLUMN()"
　　　　　　　　.Value = .Value
　　　　　　End With
　　　　　　Application.ScreenUpdating = True
　　　　　　If MsgBox("出来。続けてフィルタ？", vbYesNo) = vbYes Then Call フィルタ
　　　　End If
　　End With
End Sub

Sub フィルタ()
　　Dim rtn
　　With ActiveSheet
　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　Do
　　　　rtn = VBA.Array(Application.InputBox(Prompt:="抽出対象列を選択して", Title:="フィルタ", Default:="D:D", Type:=8))
　　　　　　If TypeName(rtn(0)) <> "Range" Then
　　　　　　　　MsgBox "キャンセル"
　　　　　　　　Exit Sub
　　　　　　ElseIf rtn(0).Areas.Count > 1 Or rtn(0).Columns.Count > 1 Then
　　　　　　　　MsgBox "ひとつの列を選んで"
　　　　　　ElseIf Application.Intersect(rtn(0), .UsedRange) Is Nothing Then
　　　　　　　　MsgBox "表の中の列を選んで"
　　　　　　Else
　　　　　　　　Exit Do
　　　　　　End If
　　　　Loop
　　　　Set rtn = rtn(0).EntireColumn
　　　　rtn.AutoFilter Field:=1, Criteria1:="<>"
　　End With
　　MsgBox Split(rtn.Address(0, 0), ":")(0) & "列、空白でない行を抽出。"
　　Set rtn = Nothing:　　rtn = Empty
End Sub
' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

お礼

素早い回答をありがとうございました。
補足のお願いにも臨機応変に対応していただき、大変助かりました。

回答No.2

cj_mover

' ' ＝＝＝＝＝＝＝＝＝＝標準モジュール＝＝＝＝＝＝＝＝＝＝Re8303136D
Sub データ統合()
　　Const sExtention As String = ".xlsx"　　' ◆拡張子◆要指定！！(".xls" ? ".csv" ? ".xlsm" ? or ?)
　　Dim wshtNew As Worksheet
　　Dim sFullPath As String
　　Dim sEscName As String
　　Dim sF As String
　　Dim flg1st As Boolean
　　sFullPath = ThisWorkbook.Path & "\"
　　sEscName = ThisWorkbook.Name
　　sF = Dir(sFullPath & "*" & sExtention)
　　If sF = "" Then
　　　　MsgBox sFullPath & "　に　" & sExtention & "ファイル　は見つかりません"
　　　　Exit Sub
　　End If
　　Application.ScreenUpdating = False
　　Set wshtNew = Worksheets.Add
　　flg1st = True
　　Do While sF <> ""
　　　　If sF <> sEscName Then
　　　　　　Debug.Print sF
　　　　　　With Workbooks.Open(sFullPath & sF)
　　　　　　　　.Worksheets(1).Cells(2, 2).CurrentRegion.Offset(1 + flg1st).Copy _
　　　　　　　　　　　　　　Destination:=wshtNew.Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　　　　　　　.Close False
　　　　　　End With
　　　　　　flg1st = False
　　　　End If
　　　　sF = Dir()
　　Loop
　　If flg1st Then
　　　　wshtNew.Delete
　　　　Application.ScreenUpdating = True
　　　　MsgBox sFullPath & "　に　" & sExtention & "ファイル　は見つかりません"
　　Else
　　　　wshtNew.Rows(1).Delete
　　　　wshtNew.Name = Format(Now, "yymmddhhmm")
　　　　Application.ScreenUpdating = True
　　　　If MsgBox("出来。続けてフィルタ？", vbYesNo) = vbYes Then Call フィルタ
　　End If
End Sub

Sub フィルタ()
　　Dim rtn
　　With ActiveSheet
　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　Do
　　　　rtn = VBA.Array(Application.InputBox(Prompt:="抽出対象列を選択して", Title:="フィルタ", Default:="D:D", Type:=8))
　　　　　　If TypeName(rtn(0)) <> "Range" Then
　　　　　　　　MsgBox "キャンセル"
　　　　　　　　Exit Sub
　　　　　　ElseIf rtn(0).Areas.Count > 1 Or rtn(0).Columns.Count > 1 Then
　　　　　　　　MsgBox "ひとつの列を選んで"
　　　　　　ElseIf Application.Intersect(rtn(0), .UsedRange) Is Nothing Then
　　　　　　　　MsgBox "表の中の列を選んで"
　　　　　　Else
　　　　　　　　Exit Do
　　　　　　End If
　　　　Loop
　　　　Set rtn = rtn(0).EntireColumn
　　　　rtn.AutoFilter Field:=1, Criteria1:="<>"
　　End With
　　MsgBox Split(rtn.Address(0, 0), ":")(0) & "列、空白でない行を抽出。"
　　Set rtn = Nothing:　　rtn = Empty
End Sub
' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

回答No.1

cj_mover

' ' ＝＝＝＝＝＝＝＝＝＝標準モジュール＝＝＝＝＝＝＝＝＝＝Re8303136D
Sub データ統合()　　'　　実行するメインプロシージャ
　　Const sFullPath As String = "C:\Users\ユーザー名\Documents\hooge"　　' ◆フォルダ◆要指定！！
　　Const sExtention As String = ".xlsx"　　' ◆拡張子◆要指定！！
　　Dim wshtNew As Worksheet
　　Dim sEscName As String
　　Dim sF As String
　　Dim flg1st As Boolean
　　sEscName = ThisWorkbook.Name
　　sF = Dir(sFullPath & "\*" & sExtention)
　　If sF = "" Then
　　　　MsgBox sFullPath & "　に　" & sExtention & "ファイル　は見つかりません"
　　　　Exit Sub
　　End If
　　Application.ScreenUpdating = False
　　Set wshtNew = Worksheets.Add
　　flg1st = True
　　Do While sF <> ""
　　　　If sF <> sEscName Then
　　　　　　Debug.Print sF
　　　　　　With Workbooks.Open(sFullPath & "\" & sF)
　　　　　　　　.Worksheets(1).Cells(2, 2).CurrentRegion.Offset(1 + flg1st).Copy _
　　　　　　　　　　　　　　Destination:=wshtNew.Cells(Rows.Count, 1).End(xlUp).Offset(1)
　　　　　　　　.Close False
　　　　　　End With
　　　　　　flg1st = False
　　　　End If
　　　　sF = Dir()
　　Loop
　　If flg1st Then
　　　　wshtNew.Delete
　　　　Application.ScreenUpdating = True
　　　　MsgBox sFullPath & "　に　" & sExtention & "ファイル　は見つかりません"
　　Else
　　　　wshtNew.Rows(1).Delete
　　　　wshtNew.Name = Format(Now, "yymmddhhmm")
　　　　Application.ScreenUpdating = True
　　　　If MsgBox("出来。続けてフィルタ？", vbYesNo) = vbYes Then Call フィルタ
　　End If
End Sub

Sub フィルタ()　　'　　オプション
　　Dim rtn
　　With ActiveSheet
　　　　If .AutoFilterMode Then .AutoFilterMode = False
　　　　Do
　　　　rtn = VBA.Array(Application.InputBox(Prompt:="抽出対象列を選択して", Title:="フィルタ", Default:="D:D", Type:=8))
　　　　　　If TypeName(rtn(0)) <> "Range" Then
　　　　　　　　MsgBox "キャンセル"
　　　　　　　　Exit Sub
　　　　　　ElseIf rtn(0).Areas.Count > 1 Or rtn(0).Columns.Count > 1 Then
　　　　　　　　MsgBox "ひとつの列を選んで"
　　　　　　ElseIf Application.Intersect(rtn(0), .UsedRange) Is Nothing Then
　　　　　　　　MsgBox "表の中の列を選んで"
　　　　　　Else
　　　　　　　　Exit Do
　　　　　　End If
　　　　Loop
　　　　Set rtn = rtn(0).EntireColumn
　　　　rtn.AutoFilter Field:=1, Criteria1:="<>"
　　End With
　　MsgBox Split(rtn.Address(0, 0), ":")(0) & "列、空白でない行を抽出。"
　　Set rtn = Nothing:　　rtn = Empty
End Sub
' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

補足

cj_moverさん早速の回答ありがとうございます。

今更の補足になりますが、複数人で使用することを考えています。
マクロを登録したファイルと統合するファイルを同一フォルダに保存しておき作業することを想定しています。
絶対参照ではなく、特に指定をしなくても同一フォルダ内を処理するようなことはできないのでしょうか。

最初に書いておけば良かったのですが、教えていただけると助かります。