A macro to Count the number of rows across all worksheets

[Milindx]

[FONT=&quot]Hi All,[/FONT]
[FONT=&quot]This is going to be my first thread. Need some help in VBA coding. A summary worksheet which would [/FONT][FONT=&quot]print[/FONT][FONT=&quot] all the worksheet names and counts of all the used rows(After row 7) of the worksheets. I also want to exclude the worksheets like table of contents.[/FONT]

[FONT=&quot]example:[/FONT]
[FONT=&quot]WorkBook with worksheets: Instructions, Table of [/FONT][FONT=&quot]contents[/FONT][FONT=&quot], Abc1, Abc2, Abc3, Abc4, ............[/FONT]

Summary Worksheet would display:
Worksheet Counts
Abc1 20
Abc2 100
Abc3 217
Abc4 530
.
.
.

Total 867
​
Thanks in Advance

 

[Domenic]

It looks like the names for the target sheets start with "Abc". Accordingly, try...

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] CreateWorksheetCounts()

    [COLOR=darkblue]Dim[/COLOR] arrResults() [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] wks [COLOR=darkblue]As[/COLOR] Worksheet
    [COLOR=darkblue]Dim[/COLOR] SheetCnt [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] RowCnt [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] TotalRowCnt [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] NextRow [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    [COLOR=darkblue]If[/COLOR] ActiveWorkbook [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
    
    SheetCnt = 0
    RowCnt = 0
    TotalRowCnt = 0
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] wks [COLOR=darkblue]In[/COLOR] ActiveWorkbook.Worksheets
        [COLOR=darkblue]If[/COLOR] Left(wks.Name, 3) = "Abc" [COLOR=darkblue]Then[/COLOR]
            SheetCnt = SheetCnt + 1
            RowCnt = Application.Max(wks.UsedRange.Rows.Count - 7, 0)
            TotalRowCnt = [COLOR=darkblue]To[/COLOR]talRowCnt + RowCnt
            [COLOR=darkblue]ReDim[/COLOR] [COLOR=darkblue]Preserve[/COLOR] arrResults(1 To 2, 1 To SheetCnt)
            arrResults(1, SheetCnt) = wks.Name
            arrResults(2, SheetCnt) = RowCnt
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR] wks
    
    [COLOR=darkblue]If[/COLOR] SheetCnt > 0 [COLOR=darkblue]Then[/COLOR]
        Worksheets.Add(before:=Worksheets(1)).Name = "Worksheet Counts"
        [COLOR=darkblue]With[/COLOR] Range("A1")
            .Font.Bold = [COLOR=darkblue]True[/COLOR]
            .Value = "Worksheet Counts"
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        Range("A2").Resize(UBound(arrResults, 2), 2).Value = Application.Transpose(arrResults)
        NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
        Cells(NextRow, "A").Value = "Total"
        Cells(NextRow, "B").Value = TotalRowCnt
    [COLOR=darkblue]Else[/COLOR]
        MsgBox "No worksheets found.", vbExclamation
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Hope this helps!