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

[TMS]

Post a sample workbook. See the yellow banner at the top of the screen.

[jeffreybrown]

Administrative Note:

Welcome to the forum.

We would very much like to help you with your query, however the thread title does not really convey what your request is about. Tell us what you are trying to do, not how you think it should be done.

Please take a moment to amend your thread title. Make sure that the title properly explains your request. Your title should be explicit and not be generic (this includes function names used without an indication of what you are trying to achieve).

Please see Forum Rule #1 about proper thread titles and adjust accordingly. To edit the thread title, open the original post to edit and then click on Go Advanced (bottom right) to access the area where you can edit your title.

(Note: this change is not optional. No help to be offered until this moderation request has been fulfilled.)

[tweacle]

Please find enclosed workbook with original macro that was written not by me and as you can see it shows stuff as "missing from tableau" on sheet 3 but when you look on sheet called TAB the data is there.

As stated what I want it to do is run macro as it is now but afterwards check sheet 3 for missing from tableau items and if data is in sheet called "TAB" then I need the line deleting from sheet 3.

[jindon]

You need to back up the file first and verify the result...

Sub test()
    Dim a, i As Long, ii As Long, txt As String, x As Range
    a = Sheets("tab").Cells(1).CurrentRegion.Resize(, 4).Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            For ii = 1 To 4
                txt = txt & Chr(2) & a(i, ii)
            Next
            .Item(txt) = Empty: txt = ""
        Next
        a = Sheets("sheet3").Cells(1).CurrentRegion.Value
        For i = 2 To UBound(a, 1)
            If a(i, 5) Like "*TAB" Then
                For ii = 1 To 4
                    txt = txt & Chr(2) & a(i, ii)
                Next
                If .exists(txt) Then
                    If x Is Nothing Then
                        Set x = Sheets("sheet3").Rows(i)
                    Else
                        Set x = Union(x, Sheets("sheet3").Rows(i))
                    End If
                End If
            End If
            txt = ""
        Next
    End With
    If Not x Is Nothing Then x.Delete
End Sub

[Mumps1]

Cross-posted at: https://www.mrexcel.com/board/thread...excel.1143688/
Please take a few minutes to read the Forum rules at the link below:

https://www.excelforum.com/forum-rul...rum-rules.html

[Sintek]

Seems to me your initial comparison code to get the result in Sheet3 in the first place was wrong...Why not address the real expectation instead of fixing holes...

[jindon]

tweacle,

You are welcome and thanks for the rep.