Hi rickmeister
Let's try this...we still have this
This Code is in the attache File. It assumes the Test Files and the Output File are in the same Folder. Let me know of issues
Option Explicit
Sub Combine_Tests()
Dim LR As Long, LR1 As Long, x As Long
Dim rng As Range
Dim wb As Workbook, wb1 As Workbook
Dim ws As Worksheet, ws1 As Worksheet
Dim myPath As String, fName As String
Dim myDate As Date
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
myPath = wb.Path & "\"
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = myPath 'this is the default folder shown
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xl*", 1 'default
.Show
If .SelectedItems.Count > 0 Then
fName = .SelectedItems(1)
Else
Exit Sub
End If
End With
myDate = InputBox("Date (dd/mm/yyyy)", "Enter the test execution date to be extracted", "")
Set wb1 = Workbooks.Open(fName)
For Each ws1 In wb1.Worksheets
If Not ws1.Name = "LKP Values" Then
With ws1
LR1 = .Range("A" & .Rows.Count).End(xlUp).Row
If Not .AutoFilterMode Then
.Range("A15").AutoFilter
End If
.Range("A15:M" & LR1).AutoFilter Field:=10, Criteria1:=myDate
Set rng = .AutoFilter.Range
x = rng.Columns(10).SpecialCells(xlCellTypeVisible).Count - 1
If x >= 1 Then
.AutoFilter.Range.Offset(1, 0).Copy
With ws
LR = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & LR).Resize(x, 1).Value = ws1.Range("B4").Value
.Range("B" & LR).PasteSpecial
End With
End If
ws1.AutoFilterMode = False
End With
End If
Next ws1
wb1.Close False
End Sub
Bookmarks