Thanks Dom for taking the time out to reply
I have tried all day to try to use your suggestion but I just could not get it to work, this is more than likely due to my inexperience, however I did find a solution so I have posted below
Option Explicit
Public Sub CompareData1()
Dim lr1 As Long
Dim lr2 As Long
Dim LR3 As Long
Dim Rng1 As Range
Dim Rng2 As Range
Dim Cell1 As Range
Dim Cell2 As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim X1 As String
Dim X2 As String
X1 = InputBox(" Please enter the first sheet you want to compare: ")
X1 = Trim(X1)
Set ws1 = Sheets(X1)
X2 = InputBox(" Please enter the second sheet you want to compare: ")
X2 = Trim(X2)
Set ws2 = Sheets(X2)
Application.ScreenUpdating = False
Sheets("Compare").Columns("A:k").Delete
ws1.Columns("E").ClearContents
ws2.Columns("E").ClearContents
lr1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
Set Rng1 = ws1.Range("A1:A" & lr1)
Set Rng2 = ws2.Range("A1:A" & lr2)
' Find Matches between sheets
For Each Cell1 In Rng1
For Each Cell2 In Rng2
If Cell1 = Cell2 And Cell1.Offset(0, 4) = "" And _
Cell2.Offset(0, 4) = "" Then
Cell1.Offset(0, 4) = "x"
Cell2.Offset(0, 4) = "x"
LR3 = Sheets("Compare").Range("A" & Rows.Count).End(xlUp).Row + 1
Cell1.Resize(1, 4).Copy Destination:=Sheets("Compare").Range("A" & LR3)
Cell2.Resize(1, 4).Copy Destination:=Sheets("Compare").Range("E" & LR3)
End If
Next Cell2
Next Cell1
' find unmatched items in First sheet
For Each Cell1 In Rng1
If Cell1.Offset(0, 4) = "" Then
LR3 = Sheets("Compare").Range("A" & Rows.Count).End(xlUp).Row + 1
Cell1.Resize(1, 4).Copy Destination:=Sheets("Compare").Range("A" & LR3)
Cell1.Copy Destination:=Sheets("Compare").Range("E" & LR3)
Cell1.Offset(0, 4) = "x"
End If
Next Cell1
' find unmatched items in Second sheet
For Each Cell2 In Rng2
If Cell2.Offset(0, 4) = "" Then
LR3 = Sheets("Compare").Range("A" & Rows.Count).End(xlUp).Row + 1
Cell2.Resize(1, 4).Copy Destination:=Sheets("Compare").Range("E" & LR3)
Cell2.Copy Destination:=Sheets("Compare").Range("A" & LR3)
Cell2.Offset(0, 4) = "x"
End If
Next Cell2
' fill blank fields with NO DATA in Compare
Sheets("Compare").Range("A2:H" & LR3).SpecialCells(xlCellTypeBlanks).Value = "NO DATA"
' sort Compare worksheet
Sheets("Compare").Range("A4:A" & LR3).Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ws1.Columns("E").ClearContents
ws2.Columns("E").ClearContents
Sheets("Compare").Columns.AutoFit
Sheets("Compare").Columns("E").EntireColumn.Insert
Columns("E:E").Select
The changes I made were
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim X1 As String
Dim X2 As String
X1 = InputBox(" Please enter the first sheet you want to compare: ")
X1 = Trim(X1)
Set ws1 = Sheets(X1)
X2 = InputBox(" Please enter the second sheet you want to compare: ")
X2 = Trim(X2)
Set ws2 = Sheets(X2)
Then just changed the named worksheets to ws1 and ws2
Thanks again
Wagstaff
Bookmarks