Accumulate Data from 10k+ Files. Very Slow. Issue with ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row

[smitetha]

Scope: I have several thousand files (14k right now) that are all in the same identical layout that I want to accumulate the data into one file. It's a collection of velocity testing data. Sheet1 is all single entry data >> one value always. Sheet2 is variable between 1-20 rows of data points. The accumulation of Sheet1 data points is always the same, accumulation of Sheet2 data points is variable.

Sheet 1:
Test: Single Value
Operator: Single Value
Test Date: Single Value
Test Time: Single Value
Gun: Single Value
Mfg / Model: Single Value
Caliber: Single Value
Serial #: Single Value
Powder: Single Value
Powder Wgt: Single Value
Lot Number: Single Value
Avg Velocity: Single Value

Sheet 2:
Rnd: Values are integers varying between 1-20 rows. (Rnd = Vel13 = Prf regarding the number of rows)
Vel13: Values are integers varying between 1-20 rows. (Rnd = Vel13 = Prf regarding the number of rows)
Prf: Values are integers varying between 1-20 rows. (Rnd = Vel13 = Prf regarding the number of rows)
File Name: Single Value


Question Part 1: I am successfully cycling through the files and collecting data for Sheet1. However, my runtime is about 28sec per 100 files. So about 66min at 14k files runtime whenever the sheet is updated. Not really acceptable... How do I speed this up?

Question Part 2: On Sheet2 I need to collect variable data using the Rnd column. See image. Data always begins in A4 so I'm trying to capture the range of (A4:LastRowTestData) using LastRowTestData = ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row but it's not working. My guess is it's the variable being defined/passed incorrectly. I can run the below in the file I'm opening and it works just fine. When I run it from my "accumulation sheet" it doesn't work.

Dim LastRowTestData As Long
LastRowTestData = ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
MsgBox LastRowTestData


End Goal: Open File 1 in selected folder, copy the range of (A4:LastRowTestData), (B4:LastRowTestData), C4:LastRowTestData) from Sheet2 to the Accumulation Sheet under the proper header. Copy the single value data from Sheet1 to Accumulation Sheet. Duplicate the Sheet1 single values on the Accumulation sheet for the Sheet2 data length.

Index to the next file, repeat the process for all files.


Code:
Sub Accumulate_All_Test_Data()

Dim myPath As String
Dim myFile As String
Dim FldrPicker As FileDialog
Dim sh As Worksheet
Dim i As Long
Dim LastRowTestData As Long

Dim Test As String
Dim Operator As String
Dim Test_Date As String
Dim Test_Time As String
Dim Gun As String
Dim Mfg_Model As String
Dim Caliber As String
Dim Serial_Num As String
Dim Powder As String
Dim Powder_Wgt As String
Dim Lot_Number As String
Dim Avg_Velocity As String
Dim Rnd As String
Dim Vel13 As String
Dim Prf As String
Dim File_Name As String

'Assign column values to the data accumulation headers
Test = "B"
Operator = "C"
Test_Date = "D"
Test_Time = "E"
Gun = "F"
Mfg_Model = "G"
Caliber = "H"
Serial_Num = "I"
Powder = "J"
Powder_Wgt = "K"
Lot_Number = "L"
Avg_Velocity = "M"
Rnd = "N"
Vel13 = "O"
Prf = "P"
File_Name = "Q"

Application.ScreenUpdating = False

Set sh = ThisWorkbook.Sheets(1)
With sh 'Clear sheet contents and write data accumulation headers
.Cells.ClearContents
.Range(Test & 2) = "Test:"
.Range(Operator & 2) = "Operator:"
.Range(Test_Date & 2) = "Test Date:"
.Range(Test_Time & 2) = "Test Time:"
.Range(Gun & 2) = "Gun:"
.Range(Mfg_Model & 2) = "Mfg / Model:"
.Range(Caliber & 2) = "Caliber:"
.Range(Serial_Num & 2) = "Serial #:"
.Range(Powder & 2) = "Powder:"
.Range(Powder_Wgt & 2) = "Powder Wgt:"
.Range(Lot_Number & 2) = "Lot Number:"
.Range(Avg_Velocity & 2) = "Avg Velocity"
.Range(Rnd & 2) = "Rnd"
.Range(Vel13 & 2) = "Vel13"
.Range(Prf & 2) = "Prf"
.Range(File_Name & 2) = "File Name"

End With

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker 'Select folder to accumulate data from
.Title = "Please Select Folder That Test Data Files Are Located In"
.AllowMultiSelect = False
.ButtonName = "Confirm Folder Location"
If .Show = -1 Then
myPath = .SelectedItems(1) & "\"
Else
End
End If
End With

myFile = Dir(myPath)


i = 3

Do While (myFile <> "" And i < 20) 'Note that I'd remove the "and" condition for i < 103. I'm currently clocking about 28sec per 100 files and am limiting how many files I'm collecting.

Workbooks.Open Filename:=myPath & myFile


'Collect data from Sheet1
sh.Range(Test & i) = ActiveWorkbook.Sheets(1).Cells(2, 2).Text 'Copy value from Test Setup Sheet "Test:"
sh.Range(Operator & i) = ActiveWorkbook.Sheets(1).Cells(3, 2).Text 'Copy value from Test Setup Sheet "Operator:"
sh.Range(Test_Date & i) = ActiveWorkbook.Sheets(1).Cells(11, 2).Text 'Copy value from Test Setup Sheet "Test Date:"
sh.Range(Test_Time & i) = ActiveWorkbook.Sheets(1).Cells(12, 2).Text 'Copy value from Test Setup Sheet "Test Time:"
sh.Range(Gun & i) = ActiveWorkbook.Sheets(1).Cells(2, 5).Text 'Copy value from Test Setup Sheet "Gun:"
sh.Range(Mfg_Model & i) = ActiveWorkbook.Sheets(1).Cells(3, 5).Text 'Copy value from Test Setup Sheet "Mfg / Model:"
sh.Range(Caliber & i) = ActiveWorkbook.Sheets(1).Cells(4, 5).Text 'Copy value from Test Setup Sheet "Caliber:"
sh.Range(Serial_Num & i) = ActiveWorkbook.Sheets(1).Cells(5, 5).Text 'Copy value from Test Setup Sheet "Serial #:"
sh.Range(Powder & i) = ActiveWorkbook.Sheets(1).Cells(7, 8).Text 'Copy value from Test Setup Sheet "Powder:"
sh.Range(Powder_Wgt & i) = ActiveWorkbook.Sheets(1).Cells(8, 8).Text 'Copy value from Test Setup Sheet "Powder Wgt:"
sh.Range(Lot_Number & i) = ActiveWorkbook.Sheets(1).Cells(9, 8).Text 'Copy value from Test Setup Sheet "Lot Number:"
sh.Range(Avg_Velocity & i) = ActiveWorkbook.Sheets(1).Cells(13, 8).Text 'Copy value from Test Setup Sheet "Avg Velocity"


'Collect data from Sheet2
' LastRowTestData = ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row NOT WORKING
' MsgBox LastRowTestData

' = ActiveWorkbook.Sheets(2).Range("A4:& ).Text 'Copy value from Test Data Sheet "Rnd"
' = ActiveWorkbook.Sheets(2).Range("B4:& ).Text 'Copy value from Test Data Sheet "Vel13"
' = ActiveWorkbook.Sheets(2).Range("C4:& ).Text 'Copy value from Test Data Sheet "Prf"

ActiveWorkbook.Close savechanges:=False

myFile = Dir
i = i + 1

Loop


Application.ScreenUpdating = True


End Sub

 

[NdNoviceHlp]

Rnd range to column 14, Vel13 to column 15, Prf to column 16. Unfortunately, array positions don't work the way that you had altered the previous code. My limited testing seems to produce your final output with this code. Dave

Sub Test2()
    Dim fso As Object, objFiles As Object, objF As Object, FileCount As Integer
    Dim Arr() As Variant, Cnt As Integer, i As Integer
    Dim Counter As Integer, FldrPicker As FileDialog, MyPath As String
    Dim WbSource As Workbook, WbTarget As Workbook, RngArr() As Variant
    Dim Test As Integer, Operator As Integer, Test_Date As Integer, Test_Time As Integer, Gun As Integer
    Dim Mfg_Model As Integer, Caliber As Integer, Serial_Num As Integer, Powder As Integer, Powder_Wgt As Integer
    Dim Lot_Number As Integer, Avg_Velocity As Integer, Rnd As Integer, Vel13 As Integer, Prf As Integer, File_Name As Integer
    Dim RngA As Range, RngB As Range, RngC As Range, LastRowRngA As Integer, LastRowRngB As Integer, LastRowRngC As Integer
    'Assign column values to the data accumulation headers
    Test = 2            'B
    Operator = 3        'C
    Test_Date = 4       'D
    Test_Time = 5       'E
    Gun = 6             'F
    Mfg_Model = 7       'G
    Caliber = 8         'H
    Serial_Num = 9      'I
    Powder = 10         'J
    Powder_Wgt = 11     'K
    Lot_Number = 12     'L
    Avg_Velocity = 13   'M
    Rnd = 14            'N
    Vel13 = 15          'O
    Prf = 16            'P
    File_Name = 17      'Q

    'Write Filter Headers
    Set WbTarget = ThisWorkbook
        With WbTarget.Sheets(1)
            .Cells.ClearContents
            .Cells(2, Test) = "Test:"
            .Cells(2, Operator) = "Operator:"
            .Cells(2, Test_Date) = "Test Date:"
            .Cells(2, Test_Time) = "Test Time:"
            .Cells(2, Gun) = "Gun:"
            .Cells(2, Mfg_Model) = "Mfg / Model:"
            .Cells(2, Caliber) = "Caliber:"
            .Cells(2, Serial_Num) = "Serial #:"
            .Cells(2, Powder) = "Powder:"
            .Cells(2, Powder_Wgt) = "Powder Wgt:"
            .Cells(2, Lot_Number) = "Lot Number:"
            .Cells(2, Avg_Velocity) = "Avg Velocity"
            .Cells(2, Rnd) = "Rnd"
            .Cells(2, Vel13) = "Vel13"
            .Cells(2, Prf) = "Prf"
            .Cells(2, File_Name) = "File Name"
        End With

    'Select folder to accumulate data from
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
            With FldrPicker
                .Title = "Please Select Folder That Test Data Files Are Located In"
                .AllowMultiSelect = False
                .ButtonName = "Confirm Folder Location"
                If .Show = -1 Then
                    MyPath = .SelectedItems(1) & "\"
            Else
            Exit Sub
                End If
            End With

    Dim StartTime As Double
    Dim MinutesElapsed As String
    StartTime = Timer

    'open folder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFiles = fso.GetFolder(MyPath).Files
        FileCount = objFiles.Count
    ReDim Arr(FileCount, 13)
    ReDim RngArr(FileCount, 3)
    
    'speed thing up
    On Error GoTo ErFix
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    'loop files and load array
    For Each objF In objFiles
        Cnt = Cnt + 1
        Workbooks.Open Filename:=objF
        Set WbSource = Workbooks(objF.Name)
        Arr(Cnt, 1) = WbSource.Sheets(1).Cells(2, 2).Text 'Copy value from Test Setup Sheet "Test:"
        Arr(Cnt, 2) = WbSource.Sheets(1).Cells(3, 2).Text 'Copy value from Test Setup Sheet "Operator:"
        Arr(Cnt, 3) = WbSource.Sheets(1).Cells(11, 2).Text 'Copy value from Test Setup Sheet "Test Date:"
        Arr(Cnt, 4) = WbSource.Sheets(1).Cells(12, 2).Text 'Copy value from Test Setup Sheet "Test Time:"
        Arr(Cnt, 5) = WbSource.Sheets(1).Cells(2, 5).Text 'Copy value from Test Setup Sheet "Gun:"
        Arr(Cnt, 6) = WbSource.Sheets(1).Cells(3, 5).Text 'Copy value from Test Setup Sheet "Mfg / Model:"
        Arr(Cnt, 7) = WbSource.Sheets(1).Cells(4, 5).Text 'Copy value from Test Setup Sheet "Caliber:"
        Arr(Cnt, 8) = WbSource.Sheets(1).Cells(5, 5).Text 'Copy value from Test Setup Sheet "Serial #:"
        Arr(Cnt, 9) = WbSource.Sheets(1).Cells(7, 8).Text 'Copy value from Test Setup Sheet "Powder:"
        Arr(Cnt, 10) = WbSource.Sheets(1).Cells(8, 8).Text 'Copy value from Test Setup Sheet "Powder Wgt:"
        Arr(Cnt, 11) = WbSource.Sheets(1).Cells(9, 8).Text 'Copy value from Test Setup Sheet "Lot Number:"
        Arr(Cnt, 12) = WbSource.Sheets(1).Cells(13, 8).Text 'Copy value from Test Setup Sheet "Avg Velocity"
        Arr(Cnt, 13) = WbSource.Name 'Write name of excel file to File_Name"
        'load ranges to array
        LastRowRngA = WbSource.Sheets(2).Cells(WbSource.Sheets(2).Rows.Count, 1).End(xlUp).Row '
        Set RngA = WbSource.Sheets(2).Range(WbSource.Sheets(2).Cells(4, 1), WbSource.Sheets(2).Cells(LastRowRngA, 1))
        RngArr(Cnt, 1) = RngA
        LastRowRngB = WbSource.Sheets(2).Cells(WbSource.Sheets(2).Rows.Count, 2).End(xlUp).Row '
        Set RngB = WbSource.Sheets(2).Range(WbSource.Sheets(2).Cells(4, 2), WbSource.Sheets(2).Cells(LastRowRngB, 2))
        RngArr(Cnt, 2) = RngB
        LastRowRngC = WbSource.Sheets(2).Cells(WbSource.Sheets(2).Rows.Count, 3).End(xlUp).Row '
        Set RngC = WbSource.Sheets(2).Range(WbSource.Sheets(2).Cells(4, 3), WbSource.Sheets(2).Cells(LastRowRngC, 3))
        RngArr(Cnt, 3) = RngC
        Workbooks(objF.Name).Close savechanges:=False
    Next objF

    'unload arrays
    With WbTarget.Sheets(1)
            For Counter = 1 To Cnt
                'call function to fill blank values and return "i"
                i = Refil(WbTarget)
                .Cells(i, Test) = Arr(Counter, 1) 'Copy value from Test Setup Sheet "Test:"
                .Cells(i, Operator) = Arr(Counter, 2) 'Copy value from Test Setup Sheet "Operator:"
                .Cells(i, Test_Date) = Arr(Counter, 3) 'Copy value from Test Setup Sheet "Test Date:"
                .Cells(i, Test_Time) = Arr(Counter, 4) 'Copy value from Test Setup Sheet "Test Time:"
                .Cells(i, Gun) = Arr(Counter, 5) 'Copy value from Test Setup Sheet "Gun:"
                .Cells(i, Mfg_Model) = Arr(Counter, 6) 'Copy value from Test Setup Sheet "Mfg / Model:"
                .Cells(i, Caliber) = Arr(Counter, 7) 'Copy value from Test Setup Sheet "Caliber:"
                .Cells(i, Serial_Num) = Arr(Counter, 8) 'Copy value from Test Setup Sheet "Serial #:"
                .Cells(i, Powder) = Arr(Counter, 9) 'Copy value from Test Setup Sheet "Powder:"
                .Cells(i, Powder_Wgt) = Arr(Counter, 10) 'Copy value from Test Setup Sheet "Powder Wgt:"
                .Cells(i, Lot_Number) = Arr(Counter, 11) 'Copy value from Test Setup Sheet "Lot Number:"
                .Cells(i, Avg_Velocity) = Arr(Counter, 12) 'Copy value from Test Setup Sheet "Avg Velocity"
                .Cells(i, File_Name) = Arr(Counter, 13) 'Write name of excel file to File_Name"
                'unload array to new range
                .Cells(i, 14).Resize(UBound(RngArr(Counter, 1)), 1).Value = RngArr(Counter, 1)
                .Cells(i, 15).Resize(UBound(RngArr(Counter, 2)), 1).Value = RngArr(Counter, 2)
                .Cells(i, 16).Resize(UBound(RngArr(Counter, 3)), 1).Value = RngArr(Counter, 3)
            i = i + 1
        Next Counter
    'call function to fill last blank values
    Call Refil(WbTarget)
    End With

ErFix:
    If Err.Number <> 0 Then
        MsgBox "error"
    End If
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Set objFiles = Nothing
    Set fso = Nothing

    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    MsgBox "Total Files Processed " & Counter - 1
    MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

Function Refil(WbTarget As Workbook) As Integer
'fills blank rows with previous values. Returns "i"
Dim LastRowTargetM As Integer, LastRowTargetN As Integer, LastRowTargetO As Integer
Dim i As Integer, RngCopy1 As Range, RngCopy2 As Range, LastRowTargetB As Integer, FillCnt As Integer
With WbTarget.Sheets(1)
LastRowTargetM = .Cells(.Rows.Count, 14).End(xlUp).Row + 1
LastRowTargetN = .Cells(.Rows.Count, 15).End(xlUp).Row + 1
LastRowTargetO = .Cells(.Rows.Count, 16).End(xlUp).Row + 1
i = Application.WorksheetFunction.Max(LastRowTargetM, LastRowTargetN, LastRowTargetO)
LastRowTargetB = .Cells(.Rows.Count, 2).End(xlUp).Row
Set RngCopy1 = .Range(.Cells(LastRowTargetB, 2), .Cells(LastRowTargetB, 13))
Set RngCopy2 = .Range(.Cells(LastRowTargetB, 17), .Cells(LastRowTargetB, 17))
For FillCnt = LastRowTargetB To (i - 1)
.Cells(FillCnt, 2).Resize(RngCopy1.Rows.Count, RngCopy1.Columns.Count).Value = RngCopy1.Cells.Value
.Cells(FillCnt, 17).Resize(RngCopy2.Rows.Count, RngCopy2.Columns.Count).Value = RngCopy2.Cells.Value
Next FillCnt
End With
Refil = i
End Function