These are the codes I am using right now. It works for the most part on my home computer with only 3 files to create the codes. Once I put it on my work computer which the code then goes through about 130 folders and pulls data from them. It seems to take a while to do and not sure if there is a better way to code it. The second problem is it only getting data up to 54 files and then seemed to stop getting the data, almost like it is looping back over the same folders. Third problem is it seems to open all the .xlsm files and not close them after getting the data and moving to the next file. I would like to have this run in a Workbook open event so it will update the files when the workbook opens or at button to run the update.
Sub VBA_Loop_Through_all_Files_in_subfolders_Using_FSO_Early_Binding()
'use const for fixed values
Const FLDR As String = "C:UsersjvitturOneDriveDesktopAttendance"
Const LIST_START_ADDR As String = "B12"
Dim oFSO As FileSystemObject, oFolder As Object, c As range
Dim oSFolderFile As Object, sFile As Object, sfolder As Object
Set oFSO = New FileSystemObject
Set oFolder = oFSO.GetFolder(FLDR)
Set c = Sheet1.range(LIST_START_ADDR) 'start here
For Each sfolder In oFolder.SubFolders 'loop through subfolders
For Each sFile In sfolder.Files 'loop all files in each subfolder
If sFile.Name Like "*.xlsm" Then 'do we want to list this file?
c.Worksheet.Hyperlinks.Add Anchor:=c, Address:=sFile.Path, _
TextToDisplay:=oFSO.GetBaseName(sFile.Name)
Set c = c.Offset(1) 'next cell down
End If 'is .xlsm file
Next sFile
Next sfolder
Dim ws As Worksheet
Dim lastRow As Long
Dim tmpArray() As String
Dim i As Integer
Dim range As range
Set ws = ThisWorkbook.Sheets("DATA PULL - TG")
With ws
lastRow = .range("B" & .Rows.Count).End(xlUp).Row
For i = 1 To lastRow
If InStr(1, .range("B" & i).Value, " ") Then
tmpArray = Split(.range("B" & i).Value, " ")
.range("B" & i).Value = tmpArray(0)
.range("C" & i).Value = tmpArray(1)
End If
Next i
End With
Call OpenHyperlinkAndCopyData
End Sub
Sub OpenHyperlinkAndCopyData()
Dim ws As Worksheet
Dim wb As Workbook
Dim cell As range
Dim hyperlinkAddress As String
Dim dataToCopy As Variant
Dim hla As Object
' Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("DATA PULL - TG")
For Each cell In ws.range("B12:B208")
If cell.Hyperlinks.Count > 0 Then
hyperlinkAddress = cell.Hyperlinks(1).Address
Workbooks.Open hyperlinkAddress
dataToCopy = Sheets("ATTENDANCE RECORD").range("C4").Value
cell.Offset(0, 2).Value = dataToCopy
dataToCopy = Sheets("ATTENDANCE RECORD").range("E2").Value
cell.Offset(0, 3).Value = dataToCopy
dataToCopy = Sheets("ATTENDANCE RECORD").range("E4").Value
cell.Offset(0, 4).Value = dataToCopy
dataToCopy = Sheets("ATTENDANCE RECORD").range("F2").Value
cell.Offset(0, 5).Value = dataToCopy
dataToCopy = Sheets("ATTENDANCE RECORD").range("F4").Value
cell.Offset(0, 15).Value = dataToCopy
dataToCopy = Sheets("ATTENDANCE RECORD").range("H4").Value
cell.Offset(0, 16).Value = dataToCopy
dataToCopy = Sheets("ATTENDANCE RECORD").range("C4").Value
cell.Offset(0, 17).Value = dataToCopy
dataToCopy = Sheets("Perfect Attendance Incentive").range("C14").Value
cell.Offset(0, 6).Value = dataToCopy
dataToCopy = Sheets("Perfect Attendance Incentive").range("D14").Value
cell.Offset(0, 7).Value = dataToCopy
dataToCopy = Sheets("Perfect Attendance Incentive").range("C13").Value
cell.Offset(0, 8).Value = dataToCopy
dataToCopy = Sheets("Perfect Attendance Incentive").range("D13").Value
cell.Offset(0, 9).Value = dataToCopy
dataToCopy = Sheets("Perfect Attendance Incentive").range("C12").Value
cell.Offset(0, 10).Value = dataToCopy
dataToCopy = Sheets("Perfect Attendance Incentive").range("D12").Value
cell.Offset(0, 11).Value = dataToCopy
dataToCopy = Sheets("Perfect Attendance Incentive").range("C11").Value
cell.Offset(0, 12).Value = dataToCopy
dataToCopy = Sheets("Perfect Attendance Incentive").range("D11").Value
cell.Offset(0, 13).Value = dataToCopy
dataToCopy = Sheets("Crewmember History with Balance").range("A1").Value
cell.Offset(0, 14).Value = dataToCopy
End If
Next cell
End Sub
4
You don’t have a Workbook.Close in the code, try this.
Option Explicit
Sub OpenHyperlinkAndCopyData()
Dim ws As Worksheet, wb As Workbook, cel As Range
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("DATA PULL - TG")
For Each cel In ws.Range("B12:B208")
If cel.Hyperlinks.Count > 0 Then
Set wb = Workbooks.Open(cel.Hyperlinks(1).Address, UpdateLinks:=True, ReadOnly:=True)
With wb.Sheets("ATTENDANCE RECORD")
cel.Offset(0, 2).Value = .Range("C4").Value
cel.Offset(0, 3).Value = .Range("E2").Value
cel.Offset(0, 4).Value = .Range("E4").Value
cel.Offset(0, 5).Value = .Range("F2").Value
cel.Offset(0, 15).Value = .Range("F4").Value
cel.Offset(0, 16).Value = .Range("H4").Value
cel.Offset(0, 17).Value = .Range("C4").Value
End With
With wb.Sheets("Perfect Attendance Incentive")
cel.Offset(0, 6).Value = .Range("C14").Value
cel.Offset(0, 7).Value = .Range("D14").Value
cel.Offset(0, 8).Value = .Range("C13").Value
cel.Offset(0, 9).Value = .Range("D13").Value
cel.Offset(0, 10).Value = .Range("C12").Value
cel.Offset(0, 11).Value = .Range("D12").Value
cel.Offset(0, 12).Value = .Range("C11").Value
cel.Offset(0, 13).Value = .Range("D11").Value
End With
cel.Offset(0, 14).Value = wb.Sheets("Crewmember History with Balance").Range("A1").Value
wb.Close
End If
Next
Application.ScreenUpdating = True
End Sub
GetAttendanceRecords.Count will return the total number of files. GetAttendanceRecords only searches one level of subfolders. Considering there are only 54 files being processed ot of 130, a recursive file search may be in order.
Option Explicit
Private Enum AttendanceColumns
acLastName = 1
acFirstName
acSubFileTitle
acCMNumber
acCMStatus
acCMHireDate
acFourthQtrDateCheck
acFourthQtrAwardEarned
acFirstQtrDateCheck
acFirstQtrAwardEarned
acSecondQtrDateCheck
acSecondQtrAwardEarned
acThirdQtrDateCheck
acThirdQtrAwardEarned
acCurrentOccurrenceBalance
acPhoneNumber
acLastDateCalendarSaved
acCMRecordedPosition
acLastColumn = acCMRecordedPosition
End Enum
Sub UpdateAttendance()
Const LIST_START_ADDR As String = "B12"
Dim Data As Variant
Data = GetAttendanceRecords
Dim Target As Range
With ThisWorkbook.Sheets("DATA PULL - TG")
Set Target = .Range(LIST_START_ADDR)
Range(Target, Target.End(xlDown)).Resize(, UBound(Data, 2)).ClearContents
Target.Resize(UBound(Data), UBound(Data, 2)).Value = Data
End With
End Sub
Function GetAttendenceFiles() As Collection
'Const FolderPath As String = "C:UsersjvitturOneDriveDesktopAttendance"
Const FolderPath As String = "D:vbasample datatemp"
Dim Map As New Collection, FSO As New Scripting.FileSystemObject, File As File, Folder As Folder
Set Folder = FSO.GetFolder(FolderPath)
For Each Folder In Folder.SubFolders
For Each File In Folder.Files
If File.Name Like "*.xlsm" Then Map.Add File
Next
Next
Set GetAttendenceFiles = Map
End Function
Private Function GetAttendanceRecords()
Dim Map As Collection
Set Map = GetAttendenceFiles
Dim Result As Variant, RowData As Variant
Dim File As File
Dim r As Long, c As Long
For r = 1 To Map.Count
Set File = Map(r)
RowData = GetAttendanceRecord(File.Path)
If r = 1 Then ReDim Result(1 To Map.Count, 1 To UBound(RowData))
For c = 1 To UBound(RowData)
Result(r, c) = RowData(c)
Next
Next
GetAttendanceRecords = Result
End Function
Private Function GetAttendanceRecord(FilePath As String) As Variant
Dim wb As Workbook
Set wb = Workbooks.Open(FilePath)
Dim wsAttendanceRecord As Worksheet
Dim wsPerfectAttendanceIncentive As Worksheet
Dim wsCrewmemberHistoryWithBalance As Worksheet
Set wsAttendanceRecord = wb.Sheets("ATTENDANCE RECORD")
Set wsPerfectAttendanceIncentive = wb.Sheets("Perfect Attendance Incentive")
Set wsCrewmemberHistoryWithBalance = wb.Sheets("Crewmember History with Balance")
Dim Result(1 To acCMRecordedPosition) As Variant
Dim Parts() As String, BaseName As String
BaseName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
Parts = Split(BaseName, ",")
'Result(acLastName) = "=HYPERLINK(" & Chr(34) & FilePath & Chr(34) & "," & Chr(34) & Parts(0) & Chr(34) & ")"
Result(acLastName) = Parts(0)
If UBound(Parts) = 1 Then Result(acFirstName) = Parts(1)
' Assign values to Result array
Result(acSubFileTitle) = wsAttendanceRecord.Range("C4").Value
Result(acCMNumber) = wsAttendanceRecord.Range("E2").Value
Result(acCMStatus) = wsAttendanceRecord.Range("E4").Value
Result(acFourthQtrDateCheck) = wsAttendanceRecord.Range("F2").Value
Result(acFourthQtrAwardEarned) = wsPerfectAttendanceIncentive.Range("C14").Value
Result(acFirstQtrDateCheck) = wsPerfectAttendanceIncentive.Range("D14").Value
Result(acFirstQtrAwardEarned) = wsPerfectAttendanceIncentive.Range("C13").Value
Result(acSecondQtrDateCheck) = wsPerfectAttendanceIncentive.Range("D13").Value
Result(acSecondQtrAwardEarned) = wsPerfectAttendanceIncentive.Range("C12").Value
Result(acThirdQtrDateCheck) = wsPerfectAttendanceIncentive.Range("D12").Value
Result(acThirdQtrAwardEarned) = wsPerfectAttendanceIncentive.Range("C11").Value
Result(acCurrentOccurrenceBalance) = wsPerfectAttendanceIncentive.Range("D11").Value
Result(acPhoneNumber) = wsCrewmemberHistoryWithBalance.Range("A1").Value
Result(acLastDateCalendarSaved) = wsAttendanceRecord.Range("F4").Value
Result(acCMRecordedPosition) = wsAttendanceRecord.Range("H4").Value
' Return the result array
GetAttendanceRecord = Result
' Close the workbook after use
wb.Close SaveChanges:=False
End Function
11