There are four lines of code that require change:
If x >= 1 Then
Set Rng = .Range(.Cells(4, 3), .Cells(lr2, 3)).SpecialCells(xlCellTypeVisible) <--------
' Set Rng = .Range(.Cells(2, 1), .Cells(lr2, 1)).SpecialCells(xlCellTypeVisible)
For Each cel In Rng
FindString = cel.Value
With ws1.Columns("C:C") <---------
' With ws1.Columns("A:A")
Set fRng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not fRng Is Nothing Then
ws2.Range(Cells(fRng.Row, 1), Cells(fRng.Row, lc1)).Copy <----------
ws1.Cells(cel.Row, 1).PasteSpecial <---------
' ws2.Range(Cells(fRng.Row, fRng.Column), Cells(fRng.Row, lc1)).Copy
' ws1.Cells(cel.Row, cel.Column).PasteSpecial
End If
End With
Next cel
End If
I ran the revised code but can't tell if changes have been applied (too much data). I know it's doing a copy/paste operation. Here's the complete revised code...test it and let me know of issues.
Option Explicit
Sub Merge_Me()
Dim wk1 As Workbook
Dim wk2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim fRng As Range
Dim Rng As Range
Dim cel As Range
Dim lr1 As Long
Dim lr2 As Long
Dim lc1 As Long
Dim lc2 As Long
Dim x As Long
Dim myPath As String
Dim MyFile As String
Dim FindString As String
Set wk1 = ThisWorkbook
Set ws1 = wk1.Sheets("Sheet1")
myPath = wk1.Path & "\"
MyFile = Dir(myPath)
Application.ScreenUpdating = False
Do While MyFile <> ""
If MyFile <> wk1.Name Then
With ws1
lr1 = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
lc1 = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
End With
Workbooks.Open myPath & MyFile
Set wk2 = ActiveWorkbook
Set ws2 = wk2.Sheets("Sheet1")
With ws2
lc2 = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
lr2 = .Cells.Find("*", .Cells(Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If Not .AutoFilterMode Then
.Range("A1").AutoFilter
End If
.Range(.Cells(1, 1), .Cells(lr2, lc2)).AutoFilter Field:=17, Criteria1:= _
xlFilterToday, Operator:=xlFilterDynamic
Set Rng = .AutoFilter.Range
x = Rng.Columns(1). _
SpecialCells(xlCellTypeVisible).Count - 1
If x >= 1 Then
Set Rng = .Range(.Cells(4, 3), .Cells(lr2, 3)).SpecialCells(xlCellTypeVisible)
' Set Rng = .Range(.Cells(2, 1), .Cells(lr2, 1)).SpecialCells(xlCellTypeVisible)
For Each cel In Rng
FindString = cel.Value
With ws1.Columns("C:C")
' With ws1.Columns("A:A")
Set fRng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not fRng Is Nothing Then
ws2.Range(Cells(fRng.Row, 1), Cells(fRng.Row, lc1)).Copy
ws1.Cells(cel.Row, 1).PasteSpecial
' ws2.Range(Cells(fRng.Row, fRng.Column), Cells(fRng.Row, lc1)).Copy
' ws1.Cells(cel.Row, cel.Column).PasteSpecial
End If
End With
Next cel
End If
End With
Application.CutCopyMode = False
wk2.Close False
End If
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Bookmarks