Summary Of Maximum Rows Used Across Each Sheet In A Workbook

**Rick Rothstein** · 09-04-2015, 02:59 PM

Originally Posted by Rick Rothstein

Unfortunately, it is back to the drawing boards for me...

Okay, I am back from the drawing board and I think the following code will work correctly in all scenarios discussed previously...

Code:

Sub SheetUsageByWorksheet()
  Dim Col As Long, X As Long, MaxRow As Long, LastRow As Long, PrevRow As Long, LastCol As Long
  Dim Addr As String, TextOut As String, Dashed() As String, Spaced() As String, WS As Worksheet
  On Error GoTo NoData
  For Each WS In Worksheets
    Addr = ""
    MaxRow = 0
    LastCol = WS.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    If LastCol Then
      For Col = 1 To LastCol
        LastRow = WS.Cells(Rows.Count, Col).End(xlUp).Offset(1).Row - 1
        If LastRow > MaxRow Then MaxRow = LastRow
        If Len(Cells(Rows.Count, Col).Formula) > 0 Then LastRow = Rows.Count
        Addr = Trim(Addr & " " & Split(Cells(1, Col).Address, "$")(1) & "-" & LastRow)
      Next
      Dashed = Split(Addr, "-")
      For X = 1 To UBound(Dashed) - 1
        If Val(Dashed(X)) = Val(Dashed(X + 1)) Then Dashed(X) = ":" & Mid(Dashed(X), InStr(Dashed(X), " ") + 1)
      Next
      Addr = Replace(Join(Dashed, "-"), "-:", ":")
      Spaced = Split(Addr)
      For X = 0 To UBound(Spaced)
        If Spaced(X) Like "*:*" Then Spaced(X) = Left(Spaced(X), InStr(Spaced(X), ":")) & Mid(Spaced(X), InStrRev(Spaced(X), ":") + 1)
      Next
      Addr = "For '" & WS.Name & "' tab with up to " & MaxRow & " rows in " & LastCol & " columns." & vbLf & vbLf & Replace(Join(Spaced), " ", "   ") & vbLf & vbLf
    End If
    TextOut = TextOut & Addr
Continue:
  Next
  MsgBox TextOut
  Exit Sub
NoData:
  Resume Continue
End Sub