I have a typo in the save line and the close line
Must be
' BaseWks.parent.SaveAs "C:\Utility " & Format(Now, "yyyy-mm-dd h-mm-ss") & ".xls"
' BaseWks.parent.Close False
Change the header range here
If FNum = 1 Then
mybook.Worksheets(ShName).Range("A2:N2").Copy _
BaseWks.Range("A1")
End If
Full macro looks like this
Sub Basic_Example_4()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim rng As Range, SearchValue As String
Dim FilterField As Integer, RangeAddress As String
Dim ShName As Variant, RwCount As Long
'**********************************************************
'***Change this five code lines before you run the macro***
'**********************************************************
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Fill in the sheet name where the data is in each workbook
'Use ShName = "Sheet1" if you want to use a sheet name instead if the index
'We use the first sheet in every workbook in this example(I use the index)
ShName = 1
'Fill in the filter range: A1 is the header of the first column and G is
'the last column in the range and it will filter on all rows on the sheet
'You can also use a fixed range like A1:G2500 if you want
RangeAddress = Range("A2:G" & Rows.Count).Address
'Field that you want to filter in the range ( 1 = column A in this
'example because the filter range start in column A
FilterField = 2
'Fill in the filter value ("<>ron" if you want the opposite)
'Or use wildcards like "*ron" for cells that start with ron or use
'"*ron*" if you look for cells where ron is a part of the cell value
SearchValue = "y"
'**********************************************************
'**********************************************************
'Add a slash after MyPath if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
'set filter range
With mybook.Worksheets(ShName)
Set sourceRange = .Range(RangeAddress)
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
If FNum = 1 Then
mybook.Worksheets(ShName).Range("A2:N2").Copy _
BaseWks.Range("A1")
End If
'Find the last row in BaseWks
rnum = RDB_Last(1, BaseWks.Cells) + 1
With sourceRange.Parent
Set rng = Nothing
'Firstly, remove the AutoFilter
.AutoFilterMode = False
'Filter the range on the FilterField column
sourceRange.AutoFilter Field:=FilterField, _
Criteria1:=SearchValue
sourceRange.AutoFilter Field:=3, Criteria1:="<>"
With .AutoFilter.Range
'Check if there are results after you use AutoFilter
RwCount = .Columns(1).Cells. _
SpecialCells(xlCellTypeVisible).Cells.Count - 1
If RwCount = 0 Then
'There is no data, only the header
Else
' Set a range without the Header row
Set rng = .Resize(.Rows.Count - 1, .Columns.Count). _
Offset(1, 0).SpecialCells(xlCellTypeVisible)
'Copy the range and the file name in column A
If rnum + RwCount < BaseWks.Rows.Count Then
BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
= mybook.Name
rng.Copy BaseWks.Cells(rnum, "B")
End If
End If
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
End If
'Close the workbook without saving
mybook.Close savechanges:=False
End If
'Open the next workbook
Next FNum
'Set the column width in the new workbook
BaseWks.Columns.AutoFit
BaseWks.parent.SaveAs "C:\Utility " & Format(Now, "yyyy-mm-dd h-mm-ss") & ".xls"
' BaseWks.parent.Close False
MsgBox "Look at the merge results in the new workbook after you click on OK"
End If
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
