New code pasted below for quick review
Sub Merge_Average()
'General variables
Dim StartTime As Double
Dim myPath As String
Dim myExtension As String
Dim FilePicker As FileDialog
Dim MinutesElapsed As String
Dim Average As Double
Dim Value As Double
'Table file variables defined below
Dim wb1 As Workbook ' Table Workbook
Dim taTimesRng As Range
Dim taStartTime As Date
Dim taEndTime As Date
Dim taCell As Range
Dim currentColumnTa As Integer ' current column number in "Table" File
Dim columnHeadingTa As String ' current column name in "Table" File
Dim taCellRow As Long
'Data file variables defined below
Dim wb2 As Workbook ' Data Workbook
Dim daTimesRng As Range
Dim daStartCell As Range
Dim daEndCell As Range
Dim daStartRow As Long
Dim daEndRow As Long
Dim currentColumnDa As Integer ' current column number in "Data" File
Dim columnHeadingDa As String ' current column name in " Data" File
StartTime = Timer ' Countdown clock
Set wb1 = ThisWorkbook
Application.ScreenUpdating = False ' Switching this to False optimizes Macro Speed.
Application.EnableEvents = False ' This blocks any popups
Application.Calculation = xlCalculationManual ' This optimizes the processor output
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) '& "\"
End With
NextCode:
If myPath = "" Then GoTo ResetSettings
Set wb2 = Workbooks.Open(Filename:=myPath)
Set daEndCell = wb2.Sheets("Data").Range("B3")
wb1.Activate
Set taTimesRng = wb1.Sheets("Table").Range(Range("B3"), Range("B3").End(xlDown))
For Each taCell In taTimesRng
taStartTime = taCell
taEndTime = taCell.Offset(, 1)
taCellRow = taCell.Row
Set daStartCell = daEndCell
Do While daStartCell < taStartTime
Set daStartCell = daStartCell.Offset(1)
Loop
Set daEndCell = daStartCell
Do While daEndCell.Offset(1) <= taEndTime
'Do While daEndCell.Offset(1) <= taEndTime
Set daEndCell = daEndCell.Offset(1)
Loop
daStartRow = daStartCell.Row 'Top row of time bracket
daEndRow = daEndCell.Row 'Bottom row of time bracket
currentColumnTa = 4
columnHeadingTa = wb1.Sheets("Table").Cells(1, currentColumnTa).Value
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Loop and match column headers in Data and Table, compute and copy average values then paste in Table sheet and then loop through rows with start and end time
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Do While columnHeadingTa <> ""
currentColumnDa = 3
columnHeadingDa = wb2.Sheets("Data").Cells(1, currentColumnDa).Value
Do While columnHeadingDa <> ""
wb2.Activate
With wb2.Sheets("Data").Select
If columnHeadingDa = columnHeadingTa Then
Average = Format(Application.WorksheetFunction.Average(Range(Cells(daStartRow, currentColumnDa), Cells(daEndRow, currentColumnDa))), "0.000")
DoEvents
wb1.Activate
With wb1.Sheets("Table").Select
ActiveSheet.Cells(taCellRow, currentColumnTa).Value = Average
End With
' End If
GoTo MasterFile
End If
End With
currentColumnDa = currentColumnDa + 1
columnHeadingDa = wb2.Sheets("Data").Cells(1, currentColumnDa).Value
Loop
MasterFile:
currentColumnTa = currentColumnTa + 1
columnHeadingTa = wb1.Sheets("Table").Cells(1, currentColumnTa).Value
Loop
Next taCell
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss") ' Determine how many seconds the code took to run
ResetSettings:
' Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' Message Box when tasks are completed
MsgBox "Task Complete!. This code ran successfully in" & MinutesElapsed & " minutes", vbInformation
End Sub
Reply With Quote
. Hence I need your help one more time respected Sir. Please and Thank You.
