Excel VBA 複数のブックから新しいブックでひとつの表に集計

質問

A B
1 　 45
2 　 62 82
3 　 51
.
.
複数のExcelファイルに上記のような表があります。「B列に数値が入力されており、なおかつA列に数値が未入力のセル」を、1個とカウントし、新しいブックでファイル名別に項目をつくり、表を作成したい考えています。↓

ファイルその(1)　 4
ファイルその(2)　 6
ファイルその(3) 　0

VBA等で集計する方法はあるでしょうか。よろしくお願いいたします。

回答No.2

nekotaru

こんな感じでしょうか

Sub a()

Dim SchFol As String
Dim wsOut As Worksheet

'検索対象フォルダを指定してください
SchFol = "D:\temop"

With Application.FileSearch
.NewSearch
.LookIn = SchFol
.SearchSubFolders = False 'サブフォルダーを検索するときはTRUEにしてください
.Filename = "*.xls"
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then

Set wsOut = ThisWorkbook.Worksheets.Add

For i = 1 To .FoundFiles.Count
Call chkbook(wsOut, .FoundFiles(i))
Next i
Else
MsgBox "検索条件を満たすファイルはありません。"
End If

End With

End Sub

Private Sub chkbook(wsOut As Worksheet, inBook As String)

Dim wbIn As Workbook
Dim wsIn As Worksheet

Dim eRowA As Long
Dim eRowB As Long
Dim eRow As Long

Dim wRow As Long
Dim outCnt As Long
Dim outRow As Long

Workbooks.Open inBook

For Each wbIn In Workbooks
If wbIn.FullName = inBook Then
Exit For
End If
Next

'全シートを調べます
For Each wsIn In wbIn.Worksheets

With wsIn
If .Cells(1, 1).Value = "" And .Cells(1, 2) = "" Then
'データなしは処理しない
Else
outCnt = 0

'データの終端を検索
eRowA = eRowGet(wsIn, "A")
eRowB = eRowGet(wsIn, "B")

If eRowA > eRowB Then
eRow = eRowA
Else
eRow = eRowB
End If

For wRow = 1 To eRow
If .Cells(wRow, 2).Value <> "" And .Cells(wRow, 1).Value = "" Then
outCnt = outCnt + 1
End If
Next

outRow = eRowGet(wsOut, "A") + 1

With wsOut
.Cells(outRow, 1) = inBook
.Cells(outRow, 2) = wsIn.Name
.Cells(outRow, 3) = outCnt
End With

End If

End With
Next
wbIn.Close (False)

End Sub

Private Function eRowGet(ws As Worksheet, wCol As String) As Long

With ws.Cells(65536, wCol)
If .Value <> "" Then
eRowGet = 65536
Else
eRowGet = .End(xlUp).Row
End If
End With

End Function

回答No.1

assault852

カウントするだけならVBAは必要ないと思いますが・・
何かチャレンジしてみました?