I use a custom built excel workbook (Project Summary) to import time sheet data and break-down the time and cost spent on a project by various team members.
Within the Project Summary I have some macros to import the data from other workbooks and paste it into the current work book.
Below the Macro to import data:
Private Sub refresh()
ThisWorkbook.Unprotect "Password"
Dim answer As Integer
answer = MsgBox("This action may take a while and will only be avaliable on the Network. Are you sure you want to proceed?", vbYesNo + vbQuestion, "Please Note")
If answer = vbYes Then
Call rf01
Call rf02
Call rf03
Call rf04
Call rf05
Call rf06
Call rf07
Call rf08
Call rf09
Call rf10
Else
End If
Sheets("Welcome").Select
ActiveSheet.Range("A1:O24").Select
ActiveWindow.Zoom = True
ActiveSheet.Range("B7").Select
Sheets("Welcome").Select
ThisWorkbook.Protect Password:="Password", Structure:=True, Windows:=True
End Sub
I use a different version of the code below for each of the 10 users to import the specific data.
Private Sub rf01()
Application.DisplayAlerts = False
Dim wb0 As Workbook
Dim wb1 As Workbook
Dim strname1 As String
strname1 = ThisWorkbook.Worksheets("Calc 01").Range("L5").Value
Set wb0 = ActiveWorkbook
Set wb1 = Workbooks.Open("\\IP Address\folder\folder\01 - User1 - Time Sheet.xlsx", True, True", True, True)
wb1.Activate
Sheets("Time Sheet").Select
Worksheets("Time Sheet").Unprotect "Password"
Worksheets("Time Sheet").Select
ActiveSheet.Range("A9").Select
Worksheets("Time Sheet").AutoFilterMode = False
Worksheets("Time Sheet").Range("A8").AutoFilter Field:=1, Criteria1:="*" & strname1 & "*", Operator:=xlFilterValues
ActiveSheet.AutoFilter.Range.Offset(1).Copy
wb0.Activate
ThisWorkbook.Worksheets("TS 01").Range("A7").PasteSpecial Paste:=xlPasteValues
ActiveSheet.Range("A2").Select
wb1.Close False, False
ThisWorkbook.Sheets("TS 01").Visible = xlVeryHidden
End Sub
At the moment this can only be done when a user is on-site and has access to our NAS server. Our NAS sync's to OneDrive, thus it should be possible to run the code while not on-site.
The problem I'm having is that the directory where the Time Sheet workbooks is stored will vary from user to user.
How would I go about prompting the person that wants to compile the report to specify the folder on their local system / OneDrive, and then import the data from the Time Sheet Workbooks?
The Time sheet workbooks has the following naming convention: usernumber - username.xlsx
I am not that proficient in VBA coding. Most all of the coding was cobbled together from various forums, websites and YouTube tutorials.
If it's stupid but it works...
I assume you have 20 sheets TS 01,Calc 01,TS 02,Calc 02 etc for the 10 names
Option Explicit
Private Sub refresh()
Dim fso As Object, oFolder As Object, colFiles As Collection
Set fso = CreateObject("Scripting.FileSystemObject")
Dim f, i As Long, msg As String, sFilename As String
Set colFiles = New Collection
' choose folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder", vbExclamation
Exit Sub
End If
Set oFolder = fso.getFolder(.SelectedItems(1))
End With
' build collection of files that match pattern
For Each f In oFolder.Files
' filename is NN - name - Timesheet.xlsx
If f.Name Like "##*-*.xlsx" Then
'Debug.Print f.Path
colFiles.Add f, CStr(f.Path)
End If
Next
' user check
If colFiles.Count > 0 Then
msg = colFiles.Count & " workbooks found in " & _
oFolder.Path & ", do you want to continue ?"
If vbNo = MsgBox(msg, vbYesNo) Then Exit Sub
Else
msg = "No workbooks found"
MsgBox msg, vbExclamation
Exit Sub
End If
' process workbooks
Dim wb As Workbook, rngTo As Range, sNo As String, sName As String
Set wb = ThisWorkbook
wb.Unprotect Password:="Password"
Application.ScreenUpdating = False
For Each f In colFiles
' filename is NN - name - Timesheet.xlsx
sNo = Left(f.Name, 2)
If sNo >= 1 And sNo <= 10 Then
sName = wb.Sheets("Calc " & sNo).Range("L5").Value
Set rngTo = wb.Sheets("TS " & sNo).Range("A7")
Call rf(f, sName, rngTo)
Else
MsgBox f.Name & " not valid file", vbExclamation
End If
Next
Application.ScreenUpdating = True
With wb.Sheets("Welcome")
.Activate
.Range("A1:O24").Select
ActiveWindow.Zoom = True
.Range("B7").Select
End With
'ThisWorkbook.Protect Password:="Password", Structure:=True, Windows:=True
'ThisWorkbook.Sheets("TS 01").Visible = xlVeryHidden
MsgBox "Process complete"
End Sub
Private Sub rf(f, sName As String, rngTo As Range)
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks.Open(f.Path, True, True, True, True)
Set ws = wb.Sheets("Time Sheet")
With ws
.Unprotect "Password"
.AutoFilterMode = False
.Range("A8").AutoFilter Field:=1, Criteria1:="*" & sName & "*", Operator:=xlFilterValues
.AutoFilter.Range.Offset(1).Copy
rngTo.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False ' clear Clipbaord
.Range("A2").Select
End With
wb.Close False, False
rngTo.Select
End Sub