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
