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

S

smitetha

New Member
Joined
Oct 26, 2013
Messages
44
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
 

Attachments

  • Excel.jpg
    Excel.jpg
    246.8 KB · Views: 12

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
How is LastRowTestData different than you expect? If you're copying data from one workbook to another, is the active workbook the workbook you think it is? Your code would be more reliable if you use

VBA Code: 
Dim wbSource As Workbook
Dim wbTarget As Workbook
Set wbSource = Workbooks(source_workbook_name)
Set wbTarget = Workbooks(target_workbook_name)

and then reference the workbooks by these variables, e.g.

VBA Code: 
LastRowSource = wbSource.Sheets(2).Cells(wbSource.Sheets(2).Rows.Count, 1).End(xlUp).Row
LastRowTarget = wbTarget.Sheets(2).Cells(wbTarget.Sheets(2).Rows.Count, 1).End(xlUp).Row

I'm not sure that this will help, but it will overall improve reliability.
 
Upvote 0
Hi smitetha. Jon has offered some great suggestions. Your going through a lot of files so it's better just to load all the source file(s) info into an array and then unload the array all at once to the target wb. Here's some code that you can trial which should significantly speed up Part 1. For Part 2, you can also load ranges into an array and then resize them when you unload them. I don't understand what your source ranges or target locations are? Anyways, trial this untested code to begin with. HTH. Dave
Code: 
 Sub Test()
Dim fso As Object, objFiles As Object, objF As Object, FileCount As Integer
Dim Arr() As Variant, Cnt As Integer, LastRowTarget As Integer, i As Integer
Dim Counter As Integer, FldrPicker As FileDialog, MyPath As String
Dim WbSource As Workbook, wbTarget As Workbook
Dim Test As String, Operator As String, Test_Date As String, Test_Time As String, Gun As String
Dim Mfg_Model As String, Caliber As String, Serial_Num As String, Powder As String, Powder_Wgt As String
Dim Lot_Number As String, Avg_Velocity As String, Rnd As String, Vel13 As String, Prf As String, 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"

'headers
Set wbTarget = ThisWorkbook
With wbTarget.Sheets(1)
.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

'select Folder
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
Exit Sub
End If
End With

'open folder
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(MyPath).Files
FileCount = objFiles.Count
ReDim Arr(FileCount, 12)
'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"
Workbooks(objF.Name).Close savechanges:=False
Next objF

'unload array
With wbTarget.Sheets(1)
LastRowTarget = .Cells(wbTarget.Sheets(1).Rows.Count, 2).End(xlUp).Row + 1
i = LastRowTarget
For Counter = 1 To Cnt
.Range(Test & i) = Arr(Counter, 1) 'Copy value from Test Setup Sheet "Test:"
.Range(Operator & i) = Arr(Counter, 2) 'Copy value from Test Setup Sheet "Operator:"
.Range(Test_Date & i) = Arr(Counter, 3) 'Copy value from Test Setup Sheet "Test Date:"
.Range(Test_Time & i) = Arr(Counter, 4) 'Copy value from Test Setup Sheet "Test Time:"
.Range(Gun & i) = Arr(Counter, 5) 'Copy value from Test Setup Sheet "Gun:"
.Range(Mfg_Model & i) = Arr(Counter, 6) 'Copy value from Test Setup Sheet "Mfg / Model:"
.Range(Caliber & i) = Arr(Counter, 7) 'Copy value from Test Setup Sheet "Caliber:"
.Range(Serial_Num & i) = Arr(Counter, 8) 'Copy value from Test Setup Sheet "Serial #:"
.Range(Powder & i) = Arr(Counter, 9) 'Copy value from Test Setup Sheet "Powder:"
.Range(Powder_Wgt & i) = Arr(Counter, 10) 'Copy value from Test Setup Sheet "Powder Wgt:"
.Range(Lot_Number & i) = Arr(Counter, 11) 'Copy value from Test Setup Sheet "Lot Number:"
.Range(Avg_Velocity & i) = Arr(Counter, 12) 'Copy value from Test Setup Sheet "Avg Velocity"
i = i + 1
Next Counter
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
End Sub
 
Upvote 0
Appreciate the feedback Jon. I went ahead and added the wbSource and wbTarget. wbTarget being Set wbTarget = ThisWorkbook at the very top of the Macro - in order to allow using changing of the file name.

I added wbSource to the lines below, step through them, and everything works fine except the very last line. I get successful values on the first two MsgBox and the error code below for the Row.Count.

I know this line has Sheets(1) and not Sheets(2) but the issue is there for both.

Thoughts?

Excel2.jpg
 
Upvote 0
smitetha said:
Appreciate the feedback Jon. I went ahead and added the wbSource and wbTarget. wbTarget being Set wbTarget = ThisWorkbook at the very top of the Macro - in order to allow using changing of the file name.

I added wbSource to the lines below, step through them, and everything works fine except the very last line. I get successful values on the first two MsgBox and the error code below for the Row.Count.

I know this line has Sheets(1) and not Sheets(2) but the issue is there for both.

Thoughts?

View attachment 100685
Click to expand...

Is there a
NdNoviceHlp said:
Hi smitetha. Jon has offered some great suggestions. Your going through a lot of files so it's better just to load all the source file(s) info into an array and then unload the array all at once to the target wb. Here's some code that you can trial which should significantly speed up Part 1. For Part 2, you can also load ranges into an array and then resize them when you unload them. I don't understand what your source ranges or target locations are? Anyways, trial this untested code to begin with. HTH. Dave
Code: 
 Sub Test()
Dim fso As Object, objFiles As Object, objF As Object, FileCount As Integer
Dim Arr() As Variant, Cnt As Integer, LastRowTarget As Integer, i As Integer
Dim Counter As Integer, FldrPicker As FileDialog, MyPath As String
Dim WbSource As Workbook, wbTarget As Workbook
Dim Test As String, Operator As String, Test_Date As String, Test_Time As String, Gun As String
Dim Mfg_Model As String, Caliber As String, Serial_Num As String, Powder As String, Powder_Wgt As String
Dim Lot_Number As String, Avg_Velocity As String, Rnd As String, Vel13 As String, Prf As String, 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"

'headers
Set wbTarget = ThisWorkbook
With wbTarget.Sheets(1)
.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

'select Folder
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
Exit Sub
End If
End With

'open folder
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(MyPath).Files
FileCount = objFiles.Count
ReDim Arr(FileCount, 12)
'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"
Workbooks(objF.Name).Close savechanges:=False
Next objF

'unload array
With wbTarget.Sheets(1)
LastRowTarget = .Cells(wbTarget.Sheets(1).Rows.Count, 2).End(xlUp).Row + 1
i = LastRowTarget
For Counter = 1 To Cnt
.Range(Test & i) = Arr(Counter, 1) 'Copy value from Test Setup Sheet "Test:"
.Range(Operator & i) = Arr(Counter, 2) 'Copy value from Test Setup Sheet "Operator:"
.Range(Test_Date & i) = Arr(Counter, 3) 'Copy value from Test Setup Sheet "Test Date:"
.Range(Test_Time & i) = Arr(Counter, 4) 'Copy value from Test Setup Sheet "Test Time:"
.Range(Gun & i) = Arr(Counter, 5) 'Copy value from Test Setup Sheet "Gun:"
.Range(Mfg_Model & i) = Arr(Counter, 6) 'Copy value from Test Setup Sheet "Mfg / Model:"
.Range(Caliber & i) = Arr(Counter, 7) 'Copy value from Test Setup Sheet "Caliber:"
.Range(Serial_Num & i) = Arr(Counter, 8) 'Copy value from Test Setup Sheet "Serial #:"
.Range(Powder & i) = Arr(Counter, 9) 'Copy value from Test Setup Sheet "Powder:"
.Range(Powder_Wgt & i) = Arr(Counter, 10) 'Copy value from Test Setup Sheet "Powder Wgt:"
.Range(Lot_Number & i) = Arr(Counter, 11) 'Copy value from Test Setup Sheet "Lot Number:"
.Range(Avg_Velocity & i) = Arr(Counter, 12) 'Copy value from Test Setup Sheet "Avg Velocity"
i = i + 1
Next Counter
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
End Sub
Click to expand...

Will begin working on trying this Dave. Appreciate the help. As I step through getting the code to work, this would be the manual entry flow. This would be for (3) separate source files. File Name.... Group 1, Group 2, Group 3 all consist of single values for each column on Sheet1. The middle section (what I would actually do as step 1) is to bring over the Rnd, Vel13, Prf values which in this example is a Row length of 5, 8, 2. After the Rnd, Vel13, Prf values are populated, I want to Copy Cells for the Source values of Sheet1 to that row length. That way when I filter the headers, all Sheet1 values associated with the Rnd, Vel13, Prf is available.
 

Attachments

  • Excel4.jpg
    Excel4.jpg
    238.8 KB · Views: 10
Upvote 0
smitetha said:
Is there a


Will begin working on trying this Dave. Appreciate the help. As I step through getting the code to work, this would be the manual entry flow. This would be for (3) separate source files. File Name.... Group 1, Group 2, Group 3 all consist of single values for each column on Sheet1. The middle section (what I would actually do as step 1) is to bring over the Rnd, Vel13, Prf values which in this example is a Row length of 5, 8, 2. After the Rnd, Vel13, Prf values are populated, I want to Copy Cells for the Source values of Sheet1 to that row length. That way when I filter the headers, all Sheet1 values associated with the Rnd, Vel13, Prf is available.
Click to expand...

Dave, was able to get your array coding to work just fine. Made some minor tweaks so that column headers can be changed in one location and it follows through the array. Time for 100files went from 28sec to 20sec. So some improvement. Because the file names are read only on the network server, I could eventually run the program one time to get all the info and skip adding anything new after running it again.

Before I being figuring out the Rnd, Vel13, Prf values, is an array the best approach still? Hopefully the picture I attached makes sense as to what I'm trying to accomplish. I appreciate your help and guidance.


VBA Code: 
Sub Test()

    Dim fso As Object, objFiles As Object, objF As Object, FileCount As Integer
    Dim Arr() As Variant, Cnt As Integer, LastRowTarget As Integer, i As Integer
    Dim Counter As Integer, FldrPicker As FileDialog, MyPath As String
    Dim WbSource As Workbook, wbTarget As Workbook
    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

    '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, 17)

    '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, Test) = WbSource.Sheets(1).Cells(2, 2).Text 'Copy value from Test Setup Sheet "Test:"
        Arr(Cnt, Operator) = WbSource.Sheets(1).Cells(3, 2).Text 'Copy value from Test Setup Sheet "Operator:"
        Arr(Cnt, Test_Date) = WbSource.Sheets(1).Cells(11, 2).Text 'Copy value from Test Setup Sheet "Test Date:"
        Arr(Cnt, Test_Time) = WbSource.Sheets(1).Cells(12, 2).Text 'Copy value from Test Setup Sheet "Test Time:"
        Arr(Cnt, Gun) = WbSource.Sheets(1).Cells(2, 5).Text 'Copy value from Test Setup Sheet "Gun:"
        Arr(Cnt, Mfg_Model) = WbSource.Sheets(1).Cells(3, 5).Text 'Copy value from Test Setup Sheet "Mfg / Model:"
        Arr(Cnt, Caliber) = WbSource.Sheets(1).Cells(4, 5).Text 'Copy value from Test Setup Sheet "Caliber:"
        Arr(Cnt, Serial_Num) = WbSource.Sheets(1).Cells(5, 5).Text 'Copy value from Test Setup Sheet "Serial #:"
        Arr(Cnt, Powder) = WbSource.Sheets(1).Cells(7, 8).Text 'Copy value from Test Setup Sheet "Powder:"
        Arr(Cnt, Powder_Wgt) = WbSource.Sheets(1).Cells(8, 8).Text 'Copy value from Test Setup Sheet "Powder Wgt:"
        Arr(Cnt, Lot_Number) = WbSource.Sheets(1).Cells(9, 8).Text 'Copy value from Test Setup Sheet "Lot Number:"
        Arr(Cnt, Avg_Velocity) = WbSource.Sheets(1).Cells(13, 8).Text 'Copy value from Test Setup Sheet "Avg Velocity"
        Arr(Cnt, File_Name) = WbSource.Name 'Write name of excel file to File_Name"
        Workbooks(objF.Name).Close savechanges:=False
    Next objF

    'unload array
    With wbTarget.Sheets(1)
        LastRowTarget = .Cells(wbTarget.Sheets(1).Rows.Count, 2).End(xlUp).Row + 1
        i = LastRowTarget
            For Counter = 1 To Cnt
                .Cells(i, Test) = Arr(Counter, Test) 'Copy value from Test Setup Sheet "Test:"
                .Cells(i, Operator) = Arr(Counter, Operator) 'Copy value from Test Setup Sheet "Operator:"
                .Cells(i, Test_Date) = Arr(Counter, Test_Date) 'Copy value from Test Setup Sheet "Test Date:"
                .Cells(i, Test_Time) = Arr(Counter, Test_Time) 'Copy value from Test Setup Sheet "Test Time:"
                .Cells(i, Gun) = Arr(Counter, Gun) 'Copy value from Test Setup Sheet "Gun:"
                .Cells(i, Mfg_Model) = Arr(Counter, Mfg_Model) 'Copy value from Test Setup Sheet "Mfg / Model:"
                .Cells(i, Caliber) = Arr(Counter, Caliber) 'Copy value from Test Setup Sheet "Caliber:"
                .Cells(i, Serial_Num) = Arr(Counter, Serial_Num) 'Copy value from Test Setup Sheet "Serial #:"
                .Cells(i, Powder) = Arr(Counter, Powder) 'Copy value from Test Setup Sheet "Powder:"
                .Cells(i, Powder_Wgt) = Arr(Counter, Powder_Wgt) 'Copy value from Test Setup Sheet "Powder Wgt:"
                .Cells(i, Lot_Number) = Arr(Counter, Lot_Number) 'Copy value from Test Setup Sheet "Lot Number:"
                .Cells(i, Avg_Velocity) = Arr(Counter, Avg_Velocity) 'Copy value from Test Setup Sheet "Avg Velocity"
                .Cells(i, File_Name) = Arr(Counter, File_Name) 'Write name of excel file to File_Name"
            i = i + 1
        Next Counter
    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
 
Upvote 0
Yes I believe the array approach will be quickest. Where are the ranges?
' = 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"
Click to expand...
sheet 2 A4 to last row of A goes to what column in the target wb? Same for B4 to last and C4 to Last? You can load these ranges at the same time as you retrieve the other information. You should be able to output to your final format without any intermediary steps. Dave
 
Upvote 0
Hey Dave, haven't changed my code below to replicate yours but mine is doing everything I want. I have ran up to 1000 files which creates about 4300 rows of data. However, when I move to running all 14k files, I get the below. Left the computer to run by itself. It's a work computer that I use for 3D modeling, so I have to believe it's plenty capable. All the files I'm opening are 9-13kb, Excel 97-2003 worksheet.xls

Any input would be helpful. I'm going to run it again trying to process all of them and add the processed count the the error message to see how many files I actually make it through.

Thanks!

Excel5.jpg



VBA Code: 
 Sub Accumulate_Range_Testing_Data()

    Dim fso As Object, objFiles As Object, objF As Object, FileCount As Long
    Dim Arr() As Variant, Cnt As Long, LastRowTarget As Long, i As Long
    Dim Counter As Long, FldrPicker As FileDialog, MyPath As String, MinutesElapsed As String
    Dim WbSource As Workbook, wbTarget As Workbook
    Dim Test As Long, Operator As Long, Test_Date As Long, Test_Time As Long, Gun As Long
    Dim Mfg_Model As Long, Caliber As Long, Serial_Num As Long, Powder As Long, Powder_Wgt As Long
    Dim Lot_Number As Long, Avg_Velocity As Long, Rnd As Long, Vel13 As Long, Prf As Long, File_Name As Long
    Dim Num_Rounds As Long, StartTime As Long
    
    'Assign column values to the Data Accumulation Headers
    File_Name = 2       'A
    Test = 3            'B
    Operator = 4        'C
    Test_Date = 5       'D
    Test_Time = 6       'E
    Gun = 7             'F
    Mfg_Model = 8       'G
    Caliber = 9         'H
    Serial_Num = 10     'I
    Powder = 11         'J
    Powder_Wgt = 12     'K
    Lot_Number = 13     'L
    Avg_Velocity = 14   'M
    Rnd = 15            'N
    Vel13 = 16          'O
    Prf = 17            'P
    
    Cnt = 0             'Make sure Cnt is 0 at macro start
    Counter = 0         'Make sure Counter is 0 at macro start

    'Write Data Accumulation Headers
    Set wbTarget = ThisWorkbook
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
      
    '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

    'Clear all cells and formatting
    Range("A1:Z1000000").Select
    Selection.Delete Shift:=xlUp

        With wbTarget.Sheets(1)
            .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

    StartTime = Timer 'Start timer

    'open folder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objFiles = fso.GetFolder(MyPath).Files
        FileCount = objFiles.Count
    ReDim Arr(FileCount * 20, 17)

    'speed thing up
    On Error GoTo ErFix
    
    Cnt = 1
    'loop files and load array
    For Each objF In objFiles
        Num_Rounds = 0
        Cnt = Cnt + Num_Rounds
        i = 0
        
        'If Cnt >= 100 Then GoTo Unload
        
        Workbooks.Open Filename:=objF
        
        Set WbSource = Workbooks(objF.Name)
        Arr(Cnt, Test) = WbSource.Sheets(1).Cells(2, 2).Text 'Copy value from Test Setup Sheet "Test:"
        Arr(Cnt, Operator) = WbSource.Sheets(1).Cells(3, 2).Text 'Copy value from Test Setup Sheet "Operator:"
        Arr(Cnt, Test_Date) = WbSource.Sheets(1).Cells(11, 2).Text 'Copy value from Test Setup Sheet "Test Date:"
        Arr(Cnt, Test_Time) = WbSource.Sheets(1).Cells(12, 2).Text 'Copy value from Test Setup Sheet "Test Time:"
        Arr(Cnt, Gun) = WbSource.Sheets(1).Cells(2, 5).Text 'Copy value from Test Setup Sheet "Gun:"
        Arr(Cnt, Mfg_Model) = WbSource.Sheets(1).Cells(3, 5).Text 'Copy value from Test Setup Sheet "Mfg / Model:"
        Arr(Cnt, Caliber) = WbSource.Sheets(1).Cells(4, 5).Text 'Copy value from Test Setup Sheet "Caliber:"
        Arr(Cnt, Serial_Num) = WbSource.Sheets(1).Cells(5, 5).Text 'Copy value from Test Setup Sheet "Serial #:"
        Arr(Cnt, Powder) = WbSource.Sheets(1).Cells(7, 8).Text 'Copy value from Test Setup Sheet "Powder:"
        Arr(Cnt, Powder_Wgt) = WbSource.Sheets(1).Cells(8, 8).Text 'Copy value from Test Setup Sheet "Powder Wgt:"
        Arr(Cnt, Lot_Number) = WbSource.Sheets(1).Cells(9, 8).Text 'Copy value from Test Setup Sheet "Lot Number:"
        Arr(Cnt, Avg_Velocity) = WbSource.Sheets(1).Cells(13, 8).Text 'Copy value from Test Setup Sheet "Avg Velocity"
        Arr(Cnt, File_Name) = WbSource.Name 'Write name of excel file to File_Name"
        
        Num_Rounds = WbSource.Sheets(2).Cells(WbSource.Sheets(2).Rows.Count, 1).End(xlUp).Row - 3 '-3 to offset rows 1, 2, 3
        'MsgBox "Num_Rounds is " & Num_Rounds
        
    Do While i < Num_Rounds
        'MsgBox "Num_Rounds is " & Num_Rounds
        Arr(Cnt, Rnd) = WbSource.Sheets(2).Cells(4 + i, 1).Value 'Copy value from Test Data Sheet "Rnd"
        'MsgBox WbSource.Sheets(2).Cells(4 + i, 1).Value
        Arr(Cnt, Vel13) = WbSource.Sheets(2).Cells(4 + i, 2).Value 'Copy value from Test Data Sheet "Vel13"
        'MsgBox WbSource.Sheets(2).Cells(4 + i, 2).Value
        Arr(Cnt, Prf) = WbSource.Sheets(2).Cells(4 + i, 3).Value  'Copy value from Test Data Sheet "Prf"
        'MsgBox WbSource.Sheets(2).Cells(4 + i, 3).Value
        'MsgBox "i is " & i
        'MsgBox "Cnt is " & Cnt
        
        i = i + 1
        Cnt = Cnt + 1
    Loop
      
        Workbooks(objF.Name).Close savechanges:=False
    Next objF

Unload:
    'unload array
    With wbTarget.Sheets(1)
        LastRowTarget = .Cells(wbTarget.Sheets(1).Rows.Count, Rnd).End(xlUp).Row + 1
        i = LastRowTarget
            For Counter = 1 To Cnt
                .Cells(i, Test) = Arr(Counter, Test) 'Copy value from Test Setup Sheet "Test:"
                .Cells(i, Operator) = Arr(Counter, Operator) 'Copy value from Test Setup Sheet "Operator:"
                .Cells(i, Test_Date) = Arr(Counter, Test_Date) 'Copy value from Test Setup Sheet "Test Date:"
                .Cells(i, Test_Time) = Arr(Counter, Test_Time) 'Copy value from Test Setup Sheet "Test Time:"
                .Cells(i, Gun) = Arr(Counter, Gun) 'Copy value from Test Setup Sheet "Gun:"
                .Cells(i, Mfg_Model) = Arr(Counter, Mfg_Model) 'Copy value from Test Setup Sheet "Mfg / Model:"
                .Cells(i, Caliber) = Arr(Counter, Caliber) 'Copy value from Test Setup Sheet "Caliber:"
                .Cells(i, Serial_Num) = Arr(Counter, Serial_Num) 'Copy value from Test Setup Sheet "Serial #:"
                .Cells(i, Powder) = Arr(Counter, Powder) 'Copy value from Test Setup Sheet "Powder:"
                .Cells(i, Powder_Wgt) = Arr(Counter, Powder_Wgt) 'Copy value from Test Setup Sheet "Powder Wgt:"
                .Cells(i, Lot_Number) = Arr(Counter, Lot_Number) 'Copy value from Test Setup Sheet "Lot Number:"
                .Cells(i, Avg_Velocity) = Arr(Counter, Avg_Velocity) 'Copy value from Test Setup Sheet "Avg Velocity"
                .Cells(i, Rnd) = Arr(Counter, Rnd) 'Copy value from Test Data Sheet "Rnd"
                .Cells(i, Vel13) = Arr(Counter, Vel13) 'Copy value from Test Data Sheet "Vel13"
                .Cells(i, Prf) = Arr(Counter, Prf) 'Copy value from Test Data Sheet "Prf"
                .Cells(i, File_Name) = Arr(Counter, File_Name) 'Write name of excel file to File_Name"
                
                i = i + 1
        Next Counter
    End With
        
    LastRowTarget = wbTarget.Sheets(1).Cells(wbTarget.Sheets(1).Rows.Count, Rnd).End(xlUp).Row 'Last row in column Rnd after data accumulation
    Range("B2:Q" & LastRowTarget).Select 'Select full range of populated cells
    
    'Duplicate Test Setup Sheet Data for Rnd, Vel13, Prf
    For Each cell In Selection
      If cell = "" Then
        cell.FillDown
      End If
    Next

    'Border accumulated date
    With Selection.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    
    'Add filter to headers
    Range("B2:Q2").Select
    Selection.AutoFilter
    Selection.Font.Bold = True
      
    Columns("B:Q").EntireColumn.AutoFit 'Autofit all columns
    
    'Bold border on outside of header
    Range("B2:Q2").BorderAround _
                LineStyle:=xlContinuous, _
                Weight:=xlMedium
                
    'Bold border on outside of accumulated data
    Range("B2:Q" & LastRowTarget).BorderAround _
                LineStyle:=xlContinuous, _
                Weight:=xlMedium
                
    'Fill color header row
    With Range("B2:Q2").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    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") 'Stop time recording
    
    'Display results
    MsgBox "Total Files Processed: " & FileCount & vbNewLine & _
    "Total Test Rounds Processed: " & LastRowTarget - 2 & vbNewLine & _
    "Total Run Time " & MinutesElapsed
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    
    Range("A1").Select

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA to copy only matching data from 2 csv workbooks into the "MasterCSV"
2
Replies
18
Views
925
Peter_SSs
Peter_SSs
D
  • Locked
  • Question Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
329
RoryA
RoryA
S
  • Question Question
Gathering Data From Multiple Files in Same Folder in Particular Range
3 4 5
Replies
41
Views
2K
kvsrinivasamurthy
K
K
  • Solved
How to copy data from single cells to merge cells and vice versa
2 3
Replies
24
Views
1K
Alex Blakenburg
A
N
  • Question Question
Pivot graph data when creating a new tab from a template.
Replies
0
Views
247
Nippyzap
N

Forum statistics

Threads
1,223,879
Messages
6,175,147
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top