Counting Rows and Columns in Folder

[esimmions]

Hello Folks,

I want to create a macro that will allow me to select a folder and then open each .xlsx file and count the number of rows and columns in each spreadsheet. (for now i want to assume there is no tabs) Then i want to display the name of the .xlsx file in column A and display their respected number of rows in column B and number of columns in C.

Right now i can list the names of all excel files in the folder, but my main problem is that the row/column count keeps getting messed up. I don't have any macro coding experience and i have just researching online and picking up code that i think will work. Any help or suggestions i would greatly appreciate!


Sub CountRows()
Dim wb As Workbook, wbXLS As Workbook
Dim LastRow As Long
Dim sPath As String, sFilename As String
Dim LastColumn As Long
Dim sFName As String
Dim intFNumber As Integer
Dim lCounter As Long
Dim lLastRow As Long
Dim sText As String
Dim TxtRng As Range
Dim xRow As Long
Dim bRow As Long
Dim cRow As Long
Dim xDirect$, xFname$, InitialFoldr$



InitialFoldr$ = "C:\Users/abc/123/" '<<< Startup folder to begin searching from

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = xFname$
xRow = xRow + 1
xFname$ = Dir

Loop

sFName = ThisWorkbook.Path & "\Excel Data (Write).txt"


DisplayAlerts = False
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
ws.Unprotect




Set TxtRng = ws.Range("B1:B5")




Application.ScreenUpdating = False
sPath = "" 'Path of XLS Files
sFilename = Dir(sPath & "*.xls")
On Error Resume Next
Do While Len(sFilename) > 0
If sFilename <> ThisWorkbook Then
Set wbXLS = Workbooks.Open(sPath & sFilename)
'open file
With ActiveSheet.UsedRange
LastRow = .Rows(.Rows.Count).Row
End With
ws.Range("B" & Rows.Count).End(xlUp).Offset(1) = LastRow


With ActiveSheet.UsedRange
LastColumn = .Columns(.Columns.Count).Column
End With
ws.Range("C" & Rows.Count).End(xlUp).Offset(1) = LastColumn

rg = sFilename
rg.Offset(0, 1) = NbRows
wbXLS.Close False 'close file
End If
sFilename = Dir

Loop
Application.ScreenUpdating = True
DisplayAlerts = True
TxtRng.Value = LastColumn


End If
End With
End Sub

 

[ParamRay]

Try using the following code instead of yours.

Before running the macro, you'll first need to change this line to your folder:

FileFold = "C:\Users\jsmith\Desktop"

Sub Test()
    
    Dim FileFold As String
    Dim FileSpec As String
    Dim FileName As String
    Dim FileInfo() As Variant
    Dim ShtCnt As Long
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim Summary As Worksheet
    
    FileFold = "C:\Users\jsmith\Desktop" 'set the folder
    FileSpec = FileFold & Application.PathSeparator & "*.xl*"
    FileName = Dir(FileSpec)
    
    If FileName = vbNullString Then
        MsgBox "No files were found that match " & FileSpec
        Exit Sub
    End If
        
    ReDim FileInfo(5, 1)
    FileInfo(1, 1) = "Workbook Path"
    FileInfo(2, 1) = "Workbook Name"
    FileInfo(3, 1) = "Worksheet Name"
    FileInfo(4, 1) = "Worksheet UsedRows"
    FileInfo(5, 1) = "Worksheet UsedColumns"
    
    ShtCnt = 1
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Do While FileName <> vbNullString
        Set wb = Workbooks.Open(FileFold & Application.PathSeparator & FileName, False)
        For Each ws In wb.Worksheets
            ShtCnt = ShtCnt + 1
            ReDim Preserve FileInfo(5, ShtCnt)
            FileInfo(1, ShtCnt) = wb.Path
            FileInfo(2, ShtCnt) = wb.Name
            FileInfo(3, ShtCnt) = ws.Name
            FileInfo(4, ShtCnt) = ws.UsedRange.Rows.Count
            FileInfo(5, ShtCnt) = ws.UsedRange.Columns.Count
        Next ws
        wb.Close SaveChanges:=False
        FileName = Dir
    Loop
    
    Set Summary = Workbooks.Add.Worksheets(1)
    Summary.Range("A1:E" & ShtCnt).Value = Application.Transpose(FileInfo)
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    MsgBox "Done"

End Sub

 

[FredMcStaire]

Brilliant. I ran this and it worked better than expected with one small issue: the column count didn't come through. As a VBA novice, i couldn't tell whether it was the code or me. I was using it for csv files.