This will be tricky VBA question!

[VBA learner ITG]

Good evening,

I am using a mac and I was wondering if anyone has ever come across a piece of VBA code that will count how many row data there are in a workbook in a folder.

For example:

If i Have a folder with 158 workbooks in can a macro count how many rows with data in are in each workbook and tell me?

it would save me time opening 158 workbooks and counting how many rows there are.

Thank you

 

[VBA learner ITG]

I forgot to mention the xlsx files there are around 6000 odd lines in each. The column which I would like count is Column H.

Thank you for your help!!

 

[steve the fish]

What could you use this information for?? Sounds like a confusing structure to me. Anyway this will be pretty slow but should work:

Sub LoopThroughFiles()

Dim folderPath As String

folderPath = ThisWorkbook.Path & "\"
            
filename = Dir(folderPath & "*.xlsx")
    
Do While filename <> ""
    Set wb = Workbooks.Open(folderPath & filename, ReadOnly:=True)
    For Each sh In wb.Sheets
        If Application.CountA(sh.Range("H:H")) > 0 Then
            myCount = myCount + sh.Range("H" & Rows.Count).End(xlUp).Row
        End If
    Next
    wb.Close False
    filename = Dir
    Set wb = Nothing
Loop

MsgBox myCount

End Sub

You may want to change the folder path to suit. As it is just place the macro enabled file in the folder where your files are and run macro LoopThroughFiles.

 

[VBA learner ITG]

Hi Steve,

Your code worked like a charm on my windows Machine, However on the Mac it fails on the below line of code:

Filename = Dir(folderPath & "*.xlsx")


The reason I need this code is to calculate how many barcodes there are so we can provide a quote on how much it will cost us to print them for the 158 stores.

 

[steve the fish]

Oh yes i dont think the mac uses * as a wildcard. Do some research on that to try to get your answer. I cant really help in that regard as i use a pc.

 

[Fuisdale2]

Just out of curiosity instead of your code showing a message box is it possible to have it list the file by Name and the associated quantity in the worksheet the code is run from?

 

[Fuisdale2]

I did try with this code and spent most of the evening trying to fix the count but to no avail.

Code:
Sub SO()

Dim MyFolder As String, matchFileSpec As String
Dim checkSubFolders As Boolean
Dim x() As String
Dim returnVal As Variant
Dim WSS As Object

Worksheets("Sheet2").Activate
Range("A2").Value = Time

Set WSS = CreateObject("WScript.Shell")

MyFolder = "C:\Users\PAH\Desktop\New folder" '// Change as required.
checkSubFolders = False '// Change as required
'Worksheets("Sheet1").Activate

MyFolder = MyFolder & IIf(Right(MyFolder, 1) = "", "", "")
matchFileSpec = MyFolder & "*.xlsx"

x = Filter(Split(WSS.Exec("CMD /C DIR """ & matchFileSpec & """ /B" & IIf(checkSubFolders, " /S", "") & " /A").StdOut.ReadAll, vbCrLf), ".xlsx", True, vbTextCompare)

For Each returnVal In x
With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = returnVal
.Offset(0, 1).Value = Split(WSS.Exec("CMD /C FindStr /R /N ""^"" """ & MyFolder & returnVal & """ | %WINDIR%\System32\find /C "":""").StdOut.ReadAll, vbCrLf)(0)
End With
Next returnVal

Set WSS = Nothing

Worksheets("Sheet2").Activate
Range("C2").Value = Time

End Sub
Sub snb()
c01 = "C:\Users\PAH\Desktop\New folder"
c02 = Dir("C:\Users\PAH\Desktop\New folder*.xlsx")

Do Until c02 = ""
With Workbooks.Open(c01 & c02, , , 1).Sheets(1).UsedRange
ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(.Rows.Count, .Columns.Count) = .Value
.Parent.Parent.Close
End With
c02 = Dir
Loop
End Sub
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim TargetWB As Workbook
MyFolder = GetFolder("C:\Users\PAH\Desktop\New folder") 'Modify as needed.
MyFile = Dir(MyFolder & "\*.xlsx") 'Modify as needed.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
Set TargetWB = Workbooks.Open(Filename:=MyFolder & "" & MyFile)
With TargetWB
If CountUsedRows(TargetWB) > 1 Then
.SaveAs "C:\Users\PAH\Desktop\New folder" & MyFile 'Modify as needed.
End If
.Close
End With
MyFile = Dir
Loop
Shell "explorer.exe C:\Users\PAH\Desktop\New folder", vbMaximizedFocus 'Open the folder.
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function CountUsedRows(Wbk As Workbook) As Long
Dim WS As Worksheet
Set WS = Wbk.Sheets(1)
CountUsedRows = WS.Range("A" & Rows.Count).End(xlUp).Row 'Modify as necessary.
End Function

 

[Fuisdale2]

Last Night I tried the following code and it worked to a degree to generate a summary report.

File name in folder worked.
Count of rows in column H failed miserably.


Code:Sub SO()

Dim MyFolder As String, matchFileSpec As String
Dim checkSubFolders As Boolean
Dim x() As String
Dim returnVal As Variant
Dim WSS As Object

Worksheets("Sheet2").Activate
Range("A2").Value = Time

Set WSS = CreateObject("WScript.Shell")

MyFolder = "C:\Users\PAH\Desktop\New folder" '// Change as required.
checkSubFolders = False '// Change as required
'Worksheets("Sheet1").Activate

MyFolder = MyFolder & IIf(Right(MyFolder, 1) = "", "", "")
matchFileSpec = MyFolder & "*.xlsx"

x = Filter(Split(WSS.Exec("CMD /C DIR """ & matchFileSpec & """ /B" & IIf(checkSubFolders, " /S", "") & " /A").StdOut.ReadAll, vbCrLf), ".xlsx", True, vbTextCompare)

For Each returnVal In x
With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = returnVal
.Offset(0, 1).Value = Split(WSS.Exec("CMD /C FindStr /R /N ""^"" """ & MyFolder & returnVal & """ | %WINDIR%\System32\find /C "":""").StdOut.ReadAll, vbCrLf)(0)
End With
Next returnVal

Set WSS = Nothing

Worksheets("Sheet2").Activate
Range("C2").Value = Time

End Sub
Sub snb()
c01 = "C:\Users\PAH\Desktop\New folder"
c02 = Dir("C:\Users\PAH\Desktop\New folder*.xlsx")

Do Until c02 = ""
With Workbooks.Open(c01 & c02, , , 1).Sheets(1).UsedRange
ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(.Rows.Count, .Columns.Count) = .Value
.Parent.Parent.Close
End With
c02 = Dir
Loop
End Sub
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim TargetWB As Workbook
MyFolder = GetFolder("C:\Users\PAH\Desktop\New folder") 'Modify as needed.
MyFile = Dir(MyFolder & "\*.xlsx") 'Modify as needed.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
Set TargetWB = Workbooks.Open(Filename:=MyFolder & "" & MyFile)
With TargetWB
If CountUsedRows(TargetWB) > 1 Then
.SaveAs "C:\Users\PAH\Desktop\New folder" & MyFile 'Modify as needed.
End If
.Close
End With
MyFile = Dir
Loop
Shell "explorer.exe C:\Users\PAH\Desktop\New folder", vbMaximizedFocus 'Open the folder.
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function CountUsedRows(Wbk As Workbook) As Long
Dim WS As Worksheet
Set WS = Wbk.Sheets(1)
CountUsedRows = WS.Range("A" & Rows.Count).End(xlUp).Row 'Modify as necessary.
End Function