Copy name, project number, hours total from all employees timesheets in a directory vba

[jimmygogo]

Hi there, I am looking for help in writing a code where I can copy employee name, project numbers and total hours worked on each project per week from employee directory. Each employee has their own excel file.

Each week (separate tab for each week) hundreds of employee fill in their time sheet (example) below. For my purpose, I want the code to open each workbook, copy name (C8), Project numbers (B13 to end) and total hours (N13 to end) and then move on to the next employee.

Employee directory

Thank you in advance for your help.

 

[jimmygogo]

jimmygogo here is an updated version of the code for the standard module:

Option Explicit

Sub Main()
  Dim FileList As Collection, FileName As Variant, strFileName As String, EmployeeWB As Workbook
  Dim ProcessDate As Date, SummaryWS As Worksheet
  Dim srcEmployeeName As String, srcProjectNumber As String, srcProjectHours As String
  Dim EmployeeWS As Worksheet, EmployeeName As String, HourCell As Range, LastRow As Long
  Dim TestDateString As String
 
  srcEmployeeName = "$C$7"
  srcProjectNumber = "$B$13:$B$35"
  srcProjectHours = "$N$13:$N$35"
 
  UserForm1.Show
  If IsDate(UserForm1.TextBox1.Value) Then
'
' THIS MAY NEED TO CHANGE IF THE INPUT IS IN DD-MM-YYYY FORMAT
'
' this converts the mm-dd-yyyy input to dd-mm-yyyy format for comparing
'
    TestDateString = Format(CDate(UserForm1.TextBox1.Value), "dd-mm-yyyy")
  Else
    Unload UserForm1
    Exit Sub
  End If
  Unload UserForm1
 
  Set SummaryWS = ActiveSheet
' find last row
  LastRow = GetLastRow(SummaryWS)
 
'  Set FileList = New Collection
' get all file names from employee folder
  Set FileList = GetAllFilenames("c:\TestFolder\*.xl*")
 
  If FileList.Count > 0 Then
    For Each FileName In FileList
      strFileName = "c:\TestFolder\" & CStr(FileName)
  '   open workbook read-only
      Set EmployeeWB = Workbooks.Open(strFileName, , True)
      For Each EmployeeWS In EmployeeWB.Worksheets
        If IsDate(EmployeeWS.Name) Then
          If TestDateString = EmployeeWS.Name Then
            EmployeeName = EmployeeWS.Range(srcEmployeeName).Value
            For Each HourCell In EmployeeWS.Range(srcProjectHours).Cells
              If HourCell.Value > 0 Then
'   copy cells from employee file to this file
                With SummaryWS
                  .Cells(LastRow + 1, 1).Value = EmployeeName
                  .Cells(LastRow + 1, 2).Value = EmployeeWS.Cells(HourCell.Row, 2)
                  .Cells(LastRow + 1, 3).Value = HourCell.Value
                End With
                LastRow = LastRow + 1
              Else
              End If
            Next HourCell
          Else
          End If
        Else
        End If
      Next EmployeeWS
  '   close employee file without saving
      EmployeeWB.Close False
    Next FileName
  End If
End Sub

Function GetAllFilenames(inPath As String) As Collection
  Dim StrFile As String, FileList As Collection
  Set FileList = New Collection
  StrFile = Dir(inPath)
  Do While Len(StrFile) > 0
    FileList.Add StrFile
    StrFile = Dir
  Loop
  Set GetAllFilenames = FileList
End Function

Function GetLastRow(sh As Worksheet) As Long
'Ron de Bruin, 5 May 2008
  On Error Resume Next
  GetLastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, _
                          LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, MatchCase:=False).Row
  On Error GoTo 0
End Function

Please note the comments near the top of this code!

If you always enter the date required in the mm-dd-yyyy format this code should work all the time. If you always enter the date required in the dd-mm-yyyy format this code will work sometimes but not always. This caution is based on the fact I am testing in the US. A complete testing should be done in the UK (or where you are) for multiple dates. For example, I tested 1-9-2022 and 2-20-2022. Then I tested 9-1-2022 and 20-2-2022. the 9-1-2022 whould not work, the other three worked properly.

Let me know how this works.

Yeyy ! this is exactly what I was looking for - Thank you so much! you are a life savor.