Copy Entire column into an array in excel vba - vba

Question

I am trying to develop a macro which will open excel files specified by user-prompted location, find a specific column and paste the entire column in the active workbook. So far I have written the code which can loop through the files in the directory, opens the file, search for the column and store the entire column in an array. Now whenever I am trying a Run Time Error saying "Overflow"! Can anyone help me to fix this issue? Also, I want to integrate below item in the macro:
1. Find multiple columns from each file and paste those columns in a sheet. So for multiple files, I should paste the columns in individual worksheet dynamically. How can I do that? Any help is appreciated. Thanks. Below is my code I have written so far:
Sub Test_Template()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String, myFile As String
Dim myExtension As String
Dim t As Range, rng As Range, rng2 As Range
Dim dblAvg As Single, eng_spd As Single, i As Integer
Dim FldrPicker As FileDialog
Dim rowCtr As Integer
Dim myarray1 As Variant
rowCtr = 2
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Execute:
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Find "Time" in Row 1
With wb.Worksheets(1).Rows(9)
Set t = .Find("Time", lookat:=xlPart)
'If found, copy the column to Sheet 2, Column A
'If not found, present a message
If Not t Is Nothing Then
'Columns(t.Column).EntireColumn.Copy _
' Destination:=Sheets(3).Range("A1")
Set rng2 = Columns(t.Column)
myarray1 = rng2
Else: MsgBox "Time Not Found"
End If
End With
'Save and Close Workbook
wb.Close 'SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
With ActiveSheet
For i = LBound(myarray1) To UBound(myarray1)
Debug.Print myarray1(i, 1)
Next
End With
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
'MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Answer 1

here is your code with clutter, like goto commands, and unused With commands removed
Sub Test_Template()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String, myFile As String
Dim myExtension As String
Dim t As Range, rng As Range, rng2 As Range
Dim dblAvg As Single, eng_spd As Single, i As Long
Dim FldrPicker As FileDialog
Dim rowCtr As Long
Dim myarray1 As Variant
rowCtr = 2
' Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show = True Then
myPath = .SelectedItems(1) & "\"
End If
End With
myPath = myPath ' In Case of Cancel
If myPath <> "" Then
myExtension = "*.xls*" ' Target File Extension (must include wildcard "*")
myFile = Dir(myPath & myExtension) ' Target Path with Ending Extention
Do While myFile <> "" ' Loop through each Excel file in folder
Set wb = Workbooks.Open(Filename:=myPath & myFile) ' Set variable equal to opened workbook
DoEvents ' yield processing time to other events
Set t = wb.Worksheets(1).Rows(9).Find("Time", lookat:=xlPart) ' Find "Time" in Row 1 ????
If Not t Is Nothing Then
' Columns(t.Column).EntireColumn.Copy _
Destination:=Sheets(3).Range("A1")
myarray1 = Columns(t.Column) ' found: copy the column to Sheet 2, Column A
Else
MsgBox "Time Not Found"
End If
wb.Close ' SaveChanges:=True ' Save and Close Workbook
DoEvents ' yield processing time to other events
For i = LBound(myarray1) To UBound(myarray1)
Debug.Print myarray1(i, 1)
Next
myFile = Dir ' Get next file name
Loop
' MsgBox "Task Complete!"
End If
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub