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

 

[LisaLou]

Thanks for the reply.

Do you mean I need to change 'blad1' to 'figures' as that is what the spreadsheet is called where I want to run the macro from? I have tried this and it stops at that line with blad1.

Really sorry for all the trouble I am giving you but I do appreciate it!

 

[BSALV]

next trial,
rightclick on the tab of your "Figures" worksheet and click on "programmacode weergeven" (the english translation ? Show programcode ?)
there you paste this, that's a event-macro that checks if there are changes in your worksheet "figures"

"blad1" is now your "Figures"

Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Address = "$A$2" Then LisaLou
End Sub

and then paste this in a normal module
Then change the date in A2, a date in the format "DDMMYY"
now just for help to see what happens (later this 'll not be shown)
in A10 you get the search subdirectory
further downwards column A, you have the number of the file, the filename, the name of the first sheet, the concidered F-range and the number of non-empty cells (=counta) in that range.
At the bottom in the statusbar, you can follow the progress of the macro
When done, you get the number in A3 and a msgbox with the number of files (later inactive).

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

     MyNetworkDir = "C:\Users\Lisap\OneDrive\Desktop\Returns\Work Folder"     '--->lisalou
     With ThisWorkbook.Sheets("Figures")                        'the name of Lisa's worksheet

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

          Filename = Dir(s & "\*.xls*")                         '1st filename
          som = 0
          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
                    som = som + Number
                    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

     'GoTo no_writing
               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)

no_writing:
     'NEXT
               Filename = Dir()
          Loop

          .Range("A1").Resize(, 4).EntireColumn.AutoFit
          .Range("A3").Value = som
     End With

     MsgBox i & " files"
End Sub

 

[LisaLou]

I have done the above but it still stops at the same line -
With ThisWorkbook.Sheets("Figures") 'the name of Lisa's worksheet

Thanks for the help.

Lisa

 

[BSALV]

what is the name of the worksheet in which you modify A2 (the date ?) ?
I thought that one was "figures", so apparently not.
Change "Figures" in that name.

 

[LisaLou]

what is the name of the worksheet in which you modify A2 (the date ?) ?
I thought that one was "figures", so apparently not.
Change "Figures" in that name.

Yes, it is called Figures