Count of rows for all sheets

[smarty1995]

Hi If any one can help me with below macro
This only counts first sheet of each file however I need count for all sheets in a workbook.



Sub CollectData()

Dim fso As Object, xlFile As Object
Dim sFolder$
Dim r&, j&

With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
If .Show Then sFolder = .SelectedItems(1) Else Exit Sub
End With
Set fso = CreateObject("Scripting.FileSystemObject")
For Each xlFile In fso.GetFolder(sFolder).Files
With Workbooks.Open(xlFile.Path)
With .Sheets(1)
j = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
.Close False
End With
r = r + 1
Cells(r, 1).Value = xlFile.Name
Cells(r, 2).Value = j
Next

End Sub

 

[davesexcel]

Change folder location to your folder location
Code will get the data from .xlsx, change if required

Sub LoopThroughFolder()

    Dim MyFile As String, Str As String, MyDir As String
    Dim wb As Workbook, ws As Worksheet
    Dim Rws As Long, rng As Range
    Dim sh As Worksheet, LstRw As Long
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)

    'change the address to suite
    MyDir = "C:\TestFolder\"

    MyFile = Dir(MyDir & "*.xlsx")    'change file extension

    ChDir MyDir
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0

    Do While MyFile <> ""
        Workbooks.Open (MyFile)
        For Each sh In ActiveWorkbook.Sheets
            With ws
                LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            End With
            With sh
                Rws = .Cells(Rows.Count, "A").End(xlUp).Row
                ws.Cells(LstRw, 1) = ActiveWorkbook.Name
                ws.Cells(LstRw, 2) = sh.Name
                ws.Cells(LstRw, 3) = Rws
            End With
        Next sh
        ActiveWorkbook.Close True

        MyFile = Dir()
    Loop

End Sub

 

[smarty1995]

Thank you.
But the code is not working as I want it to.
The code I have mentioned gives me file name in first column and its number of rows beside however it counts only for first sheet.
Please if you can help me with number rows till last sheet in subsequent columns beside one another.

 

[davesexcel]

For what purpose would this be required?

 

[Fluff]

How about

Sub smarty1995()
   Dim Fldr As String, Fname As String
   Dim ThisWs As Worksheet, Ws As Worksheet
   Dim Rw As Long, Clm As Long

   Application.ScreenUpdating = False
   Set ThisWs = ActiveSheet
   With Application.FileDialog(4)
      .AllowMultiSelect = False
      .InitialFileName = ThisWorkbook.Path
      If .Show Then Fldr = .SelectedItems(1) & "\"
   End With
   
   Fname = Dir(Fldr & "*.xls*")
   Do Until Fname = ""
      With Workbooks.Open(Fldr & Fname)
         Rw = Rw + 1
         ThisWs.Cells(Rw, 1) = .Name
         For Each Ws In .Worksheets
            Clm = Clm + 2
            ThisWs.Cells(Rw, Clm) = Ws.Name
            ThisWs.Cells(Rw, Clm + 1) = Ws.Range("A" & Rows.Count).End(xlUp).row
         Next Ws
         .Close False
      End With
      Clm = 0
      Fname = Dir()
   Loop
End Sub

 

[StuLux]

I was working on a solution for this but have just tested Fluff's response above and this appears to work fine and will list each workbook in the directory chosen downwards with a count of rows in each sheet going across together with the sheet names, nice solution.

 

[smarty1995]

yeah it works fine!

 

[Fluff]

You're welcome & thanks for the feedback