Macro to count non-blank cells in a column in multiple spreadsheets

[LisaLou]

Hi,

I am hoping for some help with a macro I need. I want to be able to type a date in cell A2 (DDMMYY) and when I press ENTER in a spreadsheet and then the macro will look in a paticular location on a network drive for this date folder and in that folder look for all spreadsheets, no matter what they are named, for all non-blank cells in column F but don't count the first Cell (F1) as this is the header.

If possible I would like the result of all the non blank cells for all spreadsheets in the Date folder entered in cell A3.

I hope this make sense and I hope it is possible.

Thanks,
Lisa

 

[BSALV]

in a paticular location on a network drive

Is the network always available ?
So on that network, there is a subdirectory within there are a lot of subdirectories, named for example "ABCD_DDMMYY" and in that subdirectory, take all the xlsx, xls, xlsm, xlsb, ... and look in the first worksheet column D ?
Any idea how many files that can be ? 1, 10, 100 ?

To start with, what is that directory on the network ? (roughly, are there spaces in that string ? )

 

[LisaLou]

Hi,

Thank you for replying.

The directory on the network is - C:\Users\Lisap\OneDrive\Desktop\Returns\Work Folder

In the 'Work Folder' there are folders named as:

080122
090122
100122

and in those date folders there are excel spreadsheets named as:

Sheet1
Sheet2
Sheet3
Sheet4

There could be up to 50 of these sheets in each date folder.

I also have a spreadsheet which is not in any of these folders and when I type the date and press enter it will count all the NON-BLANK cells in column F for all the 'Sheets' in that date. For example, I will type 080122 then press enter and in cell B3 on this spreadsheet it will return the number of non blank cells in the folder 080122 for all sheets.

Hope this makes sense?

Thanks,
Lisa

 

[BSALV]

that single space in "work folder" is fatal for this macro.
Can you rename "Work Folder" to "Work_Folder" or "WorkFolder" ?

Sub LisaLou()
     Dim MyNetworkDir, MyDate

     MyNetworkDir = "C:\Users\Lisap\OneDrive\Desktop\Returns\Work Folder"     '--->lisalou
     MyDate = "080122"                                          '--->lisalou
     s = MyNetworkDir & "\" & MyDate

     myfiles = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir """ & s & "\*.xls*"" /b").StdOut.ReadAll, vbCrLf)     'array with all excelfiles
     Range("A1").Resize(UBound(myfiles)).Value = Application.Transpose(myfiles)
     MsgBox UBound(myfiles) & " files"
     '
End Sub

 

[LisaLou]

that single space in "work folder" is fatal for this macro.
Can you rename "Work Folder" to "Work_Folder" or "WorkFolder" ?

Sub LisaLou()
     Dim MyNetworkDir, MyDate

     MyNetworkDir = "C:\Users\Lisap\OneDrive\Desktop\Returns\Work Folder"     '--->lisalou
     MyDate = "080122"                                          '--->lisalou
     s = MyNetworkDir & "\" & MyDate

     myfiles = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir """ & s & "\*.xls*"" /b").StdOut.ReadAll, vbCrLf)     'array with all excelfiles
     Range("A1").Resize(UBound(myfiles)).Value = Application.Transpose(myfiles)
     MsgBox UBound(myfiles) & " files"
     '
End Sub

I can't get it to work:

The line which starts with Range("A1").... is highlighted in yellow

Sub LisaLou()
     Dim MyNetworkDir, MyDate

     MyNetworkDir = "C:\Users\Lisap\OneDrive\Desktop\Returns\Work Folder"     '--->lisalou
     MyDate = "080122"                                          '--->lisalou
     s = MyNetworkDir & "\" & MyDate

     myfiles = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir """ & s & "\*.xls*"" /b").StdOut.ReadAll, vbCrLf)     'array with all excelfiles
     Range("A1").Resize(UBound(myfiles)).Value = Application.Transpose(myfiles)
     MsgBox UBound(myfiles) & " files"
     '
End Sub

Also, the spreadsheet which I want it to display the number of non-blank cells in column F is called 'Figures' and I want to type the date in Cell B2 in the format of DDMMYY (as this will be ongoing for the rest of the year), after entering the date, press enter and then the result will be returned in Cell B3

Thanks,
Lisa

 

[BSALV]

You can't get it working because the line above didn't find files because of that space

the "old school" method, with that space

Sub LisaLou()
     Dim MyNetworkDir, MyDate

     MyNetworkDir = "C:\Users\Lisap\OneDrive\Desktop\Returns\Work Folder"     '--->lisalou
     MyDate = "080122"                                          '--->lisalou
     s = MyNetworkDir & "\" & MyDate
     's = ThisWorkbook.Path & "\oude files" '-->Bart

     Filename = Dir(s & "\*.xls*")
     Do While Filename <> ""
     i = i + 1
          Filename = Dir()
          Range("A" & Rows.Count).End(xlUp).Offset(1) = Filename
     Loop
     MsgBox i & " files"
End Sub

 

[LisaLou]

Thanks, I did try renaming the work folder to Work_Folder and have tried both ways.

The folder looks like this:

and an example of the sheets are:

I need to be able to count the non blank cells in column F so Sheet1 should be 6.

The Figures spreadsheet I have looks like this:

The date in the format of DDMMYY is the only thing I would input and the rest would be populated. The date will be different all the time which is why I have different 'Date' folders in the 'Work Folder'

If possible, I don't need a pop up box.

I appreciate your help and time with this, I have been trying to sort this out for weeks!

Thanks.
Lisa

 

[BSALV]

Sub LisaLou()
     Dim MyNetworkDir, MyDate, WB As Workbook

     MyNetworkDir = "C:\Users\Lisap\OneDrive\Desktop\Returns\Work Folder"     '--->lisalou
     MyDate = "080122"                                          '--->lisalou
     s = MyNetworkDir & "\" & MyDate
     's = ThisWorkbook.Path '& "\oude files"                      '-->Bart

     Filename = Dir(s & "\*.xls*")                              '1st filename
     Do While Filename <> "" And i < 5                          'start loop and now only the first 5
          i = i + 1                                             'pointer

     'OPENING
          On Error Resume Next
          Set WB = Workbooks(Filename)                          'look if that workbook is already open (or possible the same name ??)
          On Error GoTo 0
          b = (WB Is Nothing)                                   'check if WB is open
          If b Then Set WB = Workbooks.Open(s & "\" & Filename)     'not open = open that file in that subdirectory

     'Quick Check
          Number = WorksheetFunction.CountA(WB.Worksheets(1).Range("B2").Resize(Rows.Count - 1))     'number of D-cells

     'CLOSING
          Application.DisplayAlerts = False                     'no alerts
          If b Then WB.Close , 0                                'if it wasn't open then close without saving
          Set WB = Nothing
          Application.DisplayAlerts = True

     'WRITE RESULT
          Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Array(Filename, Number)

     'NEXT
          Filename = Dir()
     
     Loop
     
     MsgBox i & " files"
End Sub

 

[LisaLou]

Thanks!

This works great but it isn't counting the number of non-blank cells:

It is giving the result of zero for all sheets.

Also, no matter which date I enter it is looking at the 080122 when I want it to count the sheets from the different date folders depending on which date I enter (could be 090122, 100122 etc).

Thanks,
Lisa

 

[BSALV]

write in cell A1 of sheet "Blad1" your date in format "DDMMYY"
You can change the name "Blad1" in the real name in the macro

Sub LisaLou()
     Dim MyNetworkDir, MyDate, WB As Workbook

     MyNetworkDir = "C:\Users\Lisap\OneDrive\Desktop\Returns\Work Folder"     '--->lisalou
     With ThisWorkbook.Sheets("blad1")                          'this sheet

          MyDate = .Range("A1").Value                           'in A1 is your date in format "DDMMYY"                                          '--->lisalou
          s = MyNetworkDir & "\" & MyDate
          's = ThisWorkbook.Path                                 '& "\oude files"                      '-->Bart

          Filename = Dir(s & "\*.xls*")                         '1st filename

          Do While Filename <> "" And i < 5                     'start loop and now only the first 5(delete this later or make 5->500
               Application.StatusBar = i & Space(5) & Filename  'write actual workbook in statusbar
               DoEvents
               i = i + 1                                        'counter files

     'OPENING
               Application.ScreenUpdating = False
               On Error Resume Next
               Set WB = Workbooks(Filename)                     'look if that workbook is already open (or possible the same name ??)
               On Error GoTo 0
               b = (WB Is Nothing)                              'check if WB is open
               If b Then Set WB = Workbooks.Open(s & "\" & Filename)     'not open = open that file in that subdirectory

     'Quick Check
               With WB.Worksheets(1)
                    blad = .Name
                    Set c = .Range("F" & Rows.Count).End(xlUp)  'last cell in column F
                    Set c1 = c.Offset(2 - c.Row).Resize(Application.Max(1, c.Row - 1))
                    bereik = c1.Address
                    Number = WorksheetFunction.CountA(c1)       'number of D-cells
                    DoEvents
               End With

     'CLOSING
               Application.DisplayAlerts = False                'no alerts
               If b Then WB.Close , 0                           'if it wasn't open then close without saving
               Set WB = Nothing
               Application.DisplayAlerts = True

               Application.ScreenUpdating = True
               Application.StatusBar = i & Space(5) & Filename & Space(5) & blad & Space(5) & bereik & Space(5) & Number
               DoEvents
     'WRITE RESULT
               If i = 1 Then
                    With .Range("A" & Rows.Count).End(xlUp).Offset(1)
                         .Value = "x"
                         .Resize(, 4).Value = Array("Filename", "SheetName", "Range", "CountA")
                         Application.Goto .Offset(0), 1
                    End With
               End If
               .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Array(Filename, blad, bereik, Number)

     'NEXT
               Filename = Dir()
          Loop

          .Range("A1").Resize(, 4).EntireColumn.AutoFit
     End With

     MsgBox i & " files"
End Sub