Merging a Range from Multiple Workbooks in a Folder with a Filter but Values only

[SyedGangsta]

Good afternoon every one,

I was wondering if there was a solution to my problem, I am using the wonderfully useful vba code by Ron de Bruin.

It works great, I can see that its pretty well explained too, how ever I have been having some difficulty modifying it so that it copies across cell values only.

The code uses the function also by Ron de Bruin which I have included a the top.

Any ideas on how to change the copy method so that It pastes just the values in the destination spreadsheet?

I have tried various code mods such as PasteSpecial Paste:=xlValues etc.


On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

Sub MergewithAutoFilter()
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 these five lines of code before you run the macro***
'**************************************************************

' Change this to the path\folder location of the files.
MyPath = "C:\Users\Ron\test"

' Fill in the name of the sheet containing the data.
' Use ShName = "Sheet Name" to use a sheet name instead if its
' index. This example uses the index of the first sheet in
' every workbook.
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 will
' filter on all rows on the sheet.
' You can also use a fixed range such as A1:G2500.
RangeAddress = Range("A1:G" & Rows.Count).Address

' Set the field that you want to filter in the range
' "1 = column A" in this example because the filter range
' starts in column A.
FilterField = 1

' Fill in the filter value. Use the "<>" if you want to
' filter on the absence of a term. Or use wildcards such
' as "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 = "ron"

'**********************************************************
'**********************************************************


' Add a slash after MyPath if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

' Fill the myFiles array 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 application properties.
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 myFiles array.
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 the 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
' Find the last row in target worksheet.
rnum = RDB_Last(1, BaseWks.Cells) + 1

With sourceRange.Parent
Set rng = Nothing

' Remove the AutoFilter.
.AutoFilterMode = False

' Filter the range on the
' value in filter column.
sourceRange.AutoFilter Field:=FilterField, _
Criteria1:=SearchValue

With .AutoFilter.Range

' Check to see if there are results
' after after applying the filter.
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
MsgBox "Look at the merge results in the new workbook " & _
"after you click on OK."
End If

' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub