Pasi12
08-06-2015, 04:27 PM
Hi All,
I have lo vba code that compares 2 sheets cell by cell and outputs the matched results into output sheet but I am getting errors like expected variables, and other errors, type mismatch , cant figure out?? is there a way to shorten this code to better easier code?
Basically what I am looking for to compare 2 sheets every row/cells and out put the matched to next sheet ( no sheet numbers). I don't want to assign sheet numbers if possible?
Thanks!
Pasi.
Sub Macro1()
Dim SourceSheet As Worksheet, _
CompareSheet As Worksheet
outputSheet As Worksheet
Dim rngCell As Range, _
rngSourceRange As Range, _
rngCompareRange As Range
Dim strFormulaString As String
Dim lngPasteRow As Long
Set SourceSheet = ThisWorkbook.ActiveSheet 'Source sheet name.
Set CompareSheet = "Sheet2" 'Compare sheet name.
Set outputSheet = ThisWorkbook.Worksheets.Add 'Output sheet name for matches.
Set rngSourceRange = Sheets(SourceSheet).Range("A3:A" & Sheets(SourceSheet).Range("A" & Rows.Count).End(xlUp).Row)
Set rngCompareRange = Sheets(CompareSheet).Range("E3:E" & Sheets(CompareSheet).Range("E" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
For Each rngCell In Sheets(strSourceSheet).Range(rngSourceRange.Address)
If InStr(CompareSheet, " ") = 0 Then
strFormulaString = strSourceSheet & "!" & rngCell.Address & "," & CompareSheet & "!" & rngCompareRange.Address & ",1,FALSE"
Else
strFormulaString = "'" & SourceSheet & "'!" & rngCell.Address & ",'" & CompareSheet & "'!" & rngCompareRange.Address & ",1,FALSE"
End If
'If there's no error (i.e. a match) for the current cell value, then...
If IsError(Evaluate("VLOOKUP(" & strFormulaString & ")")) = False Then
'...copy the record to the next avialbale row in Col A of the 'strOutputSheet' tab.
lngPasteRow = Sheets(outputSheet).Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets(SourceSheet).Range("A" & rngCell.Row & ":D" & rngCell.Row).Copy _
Sheets(outputSheet).Range("A" & lngPasteRow)
Application.CutCopyMode = False
End If
Next rngCell
Application.ScreenUpdating = True
'Sheets(3).Select
End Sub
I have lo vba code that compares 2 sheets cell by cell and outputs the matched results into output sheet but I am getting errors like expected variables, and other errors, type mismatch , cant figure out?? is there a way to shorten this code to better easier code?
Basically what I am looking for to compare 2 sheets every row/cells and out put the matched to next sheet ( no sheet numbers). I don't want to assign sheet numbers if possible?
Thanks!
Pasi.
Sub Macro1()
Dim SourceSheet As Worksheet, _
CompareSheet As Worksheet
outputSheet As Worksheet
Dim rngCell As Range, _
rngSourceRange As Range, _
rngCompareRange As Range
Dim strFormulaString As String
Dim lngPasteRow As Long
Set SourceSheet = ThisWorkbook.ActiveSheet 'Source sheet name.
Set CompareSheet = "Sheet2" 'Compare sheet name.
Set outputSheet = ThisWorkbook.Worksheets.Add 'Output sheet name for matches.
Set rngSourceRange = Sheets(SourceSheet).Range("A3:A" & Sheets(SourceSheet).Range("A" & Rows.Count).End(xlUp).Row)
Set rngCompareRange = Sheets(CompareSheet).Range("E3:E" & Sheets(CompareSheet).Range("E" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
For Each rngCell In Sheets(strSourceSheet).Range(rngSourceRange.Address)
If InStr(CompareSheet, " ") = 0 Then
strFormulaString = strSourceSheet & "!" & rngCell.Address & "," & CompareSheet & "!" & rngCompareRange.Address & ",1,FALSE"
Else
strFormulaString = "'" & SourceSheet & "'!" & rngCell.Address & ",'" & CompareSheet & "'!" & rngCompareRange.Address & ",1,FALSE"
End If
'If there's no error (i.e. a match) for the current cell value, then...
If IsError(Evaluate("VLOOKUP(" & strFormulaString & ")")) = False Then
'...copy the record to the next avialbale row in Col A of the 'strOutputSheet' tab.
lngPasteRow = Sheets(outputSheet).Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets(SourceSheet).Range("A" & rngCell.Row & ":D" & rngCell.Row).Copy _
Sheets(outputSheet).Range("A" & lngPasteRow)
Application.CutCopyMode = False
End If
Next rngCell
Application.ScreenUpdating = True
'Sheets(3).Select
End Sub