VBAコードをMSGボックスからサマリーレポートに変更します

Question

おはよう、

私は別のフォーラムを無駄に検索しようとしました。

フォルダー内のすべてのファイルをループし、msgeボックスにそのフォルダー内のすべてのファイルの合計行数を生成する以下のVBAコードがあります。

できるだけ私の助けが必要なのは、要約レポートを生成することです。

理想的

要約レポートには、ファイル名を表示し、あなたはすべての値が保存されている「ホーム」ワークブックを開いてみてください可能性がどのように多くの行、列H.内のデータと

Sub LoopThroughFiles() 

Dim folderPath As String 

folderPath = ThisWorkbook.Path & "\" 

Filename = Dir(folderPath & "*.xlsx") 

Do While Filename <> "" 
    Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True) 
    For Each sh In wb.Sheets 
     If Application.CountA(sh.Range("H:H")) > 0 Then 
      myCount = myCount + sh.Range("H" & Rows.Count).End(xlUp).Row 
     End If 
    Next 
    wb.Close False 
    Filename = Dir 
    Set wb = Nothing 
Loop 

MsgBox myCount 

End Sub 

Answer 1

表示されます。基本的には、新しいワークブックを開いて、各ファイルのループ中にファイルのパスと行数を新しいワークブックに貼り付けます。うまくいけば、これは助けになるか、少なくともあなたがしようとしていることをやる方法のアイデアを与える。 `

Sub LoopThroughFiles() 

Dim folderPath As String 
Dim summarySheet as Workbook 
set summarySheet = workbook.add 

folderPath = ThisWorkbook.Path & "\" 

Filename = Dir(folderPath & "*.xlsx") 

Do While Filename <> "" 
    Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True) 
    For Each sh In wb.Sheets 
     If Application.CountA(sh.Range("H:H")) > 0 Then 
      myCount = myCount + sh.Range("H" & Rows.Count).End(xlUp).Row 
     End If 
    Next 
    wb.Close False 
    summarySheet.activate 
    Range("A:A").insert Shift:=xlDown 
    Cells(1,1) = Filename 
    Cells(1,2) = myCount 
    Filename = Dir 
    Set wb = Nothing 
Loop 

MsgBox myCount 

End Sub`