'Check Public Function Check() As Variant On Error GoTo erlb Dim StrDir As String StrDir = ThisWorkbook.Worksheets("Path").Range("B2") objfile = Dir(StrDir & "*.xlsx") ThisWorkbook.Worksheets("Result").Activate With ActiveSheet .Range("A2:B400").Select ' .Cells.Select Selection.ClearContents .Range("A1").Select End With Application.ScreenUpdating = False Do While objfile <> "" Workbooks.Open StrDir & "" & objfile ' Workbooks(objfile).Activate ActiveWorkbook.Worksheets("Sheet1").Activate maxRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
iCnt = 0 startRow = 9 With ActiveSheet For iRow = startRow To maxRow If Trim(ActiveSheet.Cells(iRow, 1)) <> "" Then If Trim(ActiveSheet.Cells(iRow, 2)) = "" Then iCnt = iCnt + 1 End If Else Exit For End If Next End With Workbooks(objfile).Activate 'Workbooks(objfile).Close ActiveWorkbook.Close With ThisWorkbook.Worksheets("結果") resultmaxRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row .Cells(resultmaxRow + 1, 1) = objfile .Cells(resultmaxRow + 1, 2) = iCnt End With objfile = Dir Loop Application.ScreenUpdating = True MsgBox "計算完了" Exit Function erlb:
MsgBox Err.Number & Err.Description End Function