ファイル内で一番行数が多いシート名を取得する

エクセルvbaを使用し、同じフォルダ内のファイルで、一番行数が多いシート名と行数を取得し、ファイル名と共に記入します。
マクロファイル内に「集計」シートを作ってください。
また、1行目のA-C列に、ブック名、シート名、行数と入れてください。(お手数をおかけいたします。。。)2行目からはじめます。

参考サイトさん
ファイルの一覧を取得する
最終行・最終列の取得方法(End,CurrentRegion,SpecialCells,UsedRange)

Sub test()
    
    Dim mypath As String
    mypath = ThisWorkbook.Path
    Dim buf As String
    buf = Dir(mypath & "\*.xls*")
    
    Do While buf <> ""
       DoEvents
        
      If ThisWorkbook.Name <> buf Then
    
        Dim wb As Workbook
        Set wb = Workbooks.Open(Filename:=mypath & "\" & buf, UpdateLinks:=0)
        
        Dim tmp_ws As Worksheet
        Set tmp_ws = Worksheets.Add
        
        Dim i As Long
        i = 0
        
        Dim ws As Worksheet, max_row As Long, max_row_ws As String
        For Each ws In Worksheets
            Dim last_row As Long
            With ws.UsedRange
                last_row = .Row + .Rows.Count - 1
            End With
            
            With tmp_ws
                i = i + 1
                .Cells(i, 1) = ws.Name
                .Cells(i, 2) = last_row
            End With
        Next
        
        With tmp_ws
            Dim tmp_last_row As Long
            tmp_last_row = .Cells(Rows.Count, 1).End(xlUp).Row
            
            Dim max_cnt As Long, ws_name As String
            max_cnt = WorksheetFunction.Max(.Range(Range("B1"), Cells(tmp_last_row, "B")))
            If WorksheetFunction.CountIf(.Range(Range("B1"), Cells(tmp_last_row, "B")), max_cnt) > 1 Then
                MsgBox "同じ行のシートが2つ以上あります。いったん止めます。どのシートにするか、セルを選んでください。"
                Stop
                ws_name = Selection
            Else
                ws_name = WorksheetFunction.XLookup(max_cnt, .Range(.Range("B1"), .Cells(tmp_last_row, "B")), _
               .Range(.Range("A1"), .Cells(tmp_last_row, "A")), "")
            End If
          
        End With
        
        With ThisWorkbook.Worksheets("集計")
            last_row = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Cells(last_row, 1) = wb.Name
            .Cells(last_row, 2) = ws_name
            .Cells(last_row, 3) = max_cnt
        End With
        
        Application.DisplayAlerts = False
        tmp_ws.Delete
        wb.Close
        Application.DisplayAlerts = True
        
        Set wb = Nothing
        Set tmp_ws = Nothing
        Set ws = Nothing
       End If
        
      buf = Dir()
    Loop
    
    MsgBox "終わります"
End Sub

記事は以上になります。
ここまでご覧くださり、ありがとうございました。

 

おすすめの記事