macro is showing as data missing but it is not missing and cant get it to amend.

[tweacle]

Hi

First of all I will admit that I have cheated a bit and copied from other macros into this one and this is my very first attempt at writing one. What I am trying to do is get it to look on sheet 3 and in column E there will be some entries that say "MISSING FROM TABLEAU" .

Ive checked and the entries are not missing.

What im trying to do is look on sheet 3 for the ones that are marked up "MISSING FROM TABLEAU" and compare against sheet called "TAB" . If the data is an exact match then I need that row deleting from sheet 3. When I mean an exact match I mean that data in columns A-D on the row must match.

The data is not in line order on both sheets and could be anywhere in the sheet so I need it to look down all the rows for each individual entry.

Can anyone help.

Thanks

Option Explicit

Sub DeleteIdenticalRecordsFromTwoSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long, i As Long
Dim x, y, xx(), yy(), dict1, dict2
Dim delRng1 As Range, delRng2 As Range

Application.ScreenUpdating = False

Set ws1 = Worksheets("TAB")
Set ws2 = Worksheets("Sheet3")

lr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row

ws1.Range("A1:D" & lr1).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo

lr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
x = ws1.Range("A1:D" & lr1).Value
y = ws2.Range("A1:D" & lr2).Value

Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    dict1.Item(x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4)) = ws1.Range("A" & i).Address
Next i

For i = 1 To UBound(y, 1)
    dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)) = ws2.Range("A" & i).Address
Next i

ws1.Columns("E").Clear
ws2.Columns("E").Clear



For i = 1 To UBound(y, 1)
    If dict1.exists(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)) Then
        If delRng2 Is Nothing Then
            Set delRng2 = ws2.Range(dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)))
        Else
            Set delRng2 = Union(delRng2, ws2.Range(dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4))))
        End If
    End If
Next i


If Not delRng1 Is Nothing Then delRng1.EntireRow.Delete
If Not delRng2 Is Nothing Then delRng2.EntireRow.Delete

lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row

y = ws2.Range("A1:D" & lr2).Value


Application.ScreenUpdating = True
End SubOption Explicit

Sub DeleteIdenticalRecordsFromTwoSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long, i As Long
Dim x, y, xx(), yy(), dict1, dict2
Dim delRng1 As Range, delRng2 As Range

Application.ScreenUpdating = False

Set ws1 = Worksheets("TAB")
Set ws2 = Worksheets("Sheet3")

lr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row

ws1.Range("A1:D" & lr1).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo

lr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
x = ws1.Range("A1:D" & lr1).Value
y = ws2.Range("A1:D" & lr2).Value

Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    dict1.Item(x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4)) = ws1.Range("A" & i).Address
Next i

For i = 1 To UBound(y, 1)
    dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)) = ws2.Range("A" & i).Address
Next i

ws1.Columns("E").Clear
ws2.Columns("E").Clear



For i = 1 To UBound(y, 1)
    If dict1.exists(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)) Then
        If delRng2 Is Nothing Then
            Set delRng2 = ws2.Range(dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)))
        Else
            Set delRng2 = Union(delRng2, ws2.Range(dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4))))
        End If
    End If
Next i


If Not delRng1 Is Nothing Then delRng1.EntireRow.Delete
If Not delRng2 Is Nothing Then delRng2.EntireRow.Delete

lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row

y = ws2.Range("A1:D" & lr2).Value


Application.ScreenUpdating = True
End Sub