excelvba
Better way of coding this to get the data
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:\Users\jvittur\OneDrive\Desktop\Attendance"
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
Solution
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:\Users\jvittur\OneDrive\Desktop\Attendance"
Const FolderPath As String = "D:\vba\sample data\temp"
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
- Constrain a Specman list so it doesn't have identical values in consecutive elements
- How to type cast a list of uint to a list of vr_ahb_data in Specman?
- Static fields/methods in e
- What is the difference between deep_copy and gen keeping in Specman?
- Specman UVM: What is the difference between write_reg { .field == 2;}; and write_reg_fields?
- Does Specman support optional parameters to a method?
- Specman e: When colon equal sign ":=" should be used?
- Specman e: Is there a way to know how many values there is in an enumerated type?
- Specman e error: No match for file when using "for each line in file"
- How to run e file one by one? Not in parallel test
- Specman/e constraint (for each in) iteration
- Specman e: How driver's items queue can be locked from a sequence?
- Specman e: How to print variable's address?
- Specman e: "keep type .. is a" fails to refine the type of a field
- Specman soft select on variable, decimal vs. hexadecimal values
- Specman e: How to print a pointer to a struct?
- Specman e: Is there a way to print unit instance name?
- Specman e: simultaneous events error
- Specman e coverage: ignored values appear in the coverage statistics
- Specman e: How a sequence should be started when gen_and_start_main constrained to FALSE?
- Specman/e list of lists (multidimensional array)
- Does Specman e have struct constructor?
- Specman e: How the predefined sequence.item should be used?
- Specman e: define-as-computed macro error
- Specman e UVM: Why to inherit from uvm_* units?
- Specman e: A sequence drives its BFM also its MAIN was not defined in a test
- e HVL (IEEE 1647): expect expression fails unexpectedly
- Specman e subtyping: How to refer to FALSE value of conditional field in when/extend subtyping?
- e HVL (IEEE 1647): How to set 'X' value?
- Difference between declaring an event that is sensitive to a simple_port value and event_port