asked on

if a cell doesnt match another cell in a different sheet remove the original cell in excel

In the same workbook I have a column (colA) in sheet1 and a column in sheet2 (colA) and the same in sheet 3&4. There is other info in the other columns in each sheet

In the column are reference numbers. I would like to make sure that the same number is in all the sheets. If it isnt, then the entire row should be removed for the sheet that the match is being done from. I will of course be running this on all the sheets so I will eventually end up with the same numbers in the same rows.

As an example:

Sheet 1 Sheet 2 Sheet 3
leftPos      JWA        leftPos        JWB        leftPos      JWC
100260304      96      100260304      62      100202137      1
100735392      129      100724039      1      100260304      75
100805662      122      100735392      175      100735392      306

So the following should be removed

Sheet 1 100805662 122
Sheet 2 100724039 1
Sheet 3 100202137      1

Ejgil Hedegaard

Try this, run the macro in module 1 in attached file.

Option Explicit

Sub RemoveItemsNotOnAllSheets()
    Dim ws As Worksheet, wsCompare As Worksheet, wsNow As Worksheet
    Dim rw As Long, rwStart As Long, rwEnd As Long, i As Integer
    Dim SheetName As String, nbrSheets As Integer
    
    Application.ScreenUpdating = False
    ThisWorkbook.Activate
    Set wsNow = ActiveSheet
    For Each ws In Worksheets
        If ws.Name = "CompareSheet" Then
            i = 1
            Set wsCompare = ws
            wsCompare.Cells.Clear
        End If
    Next ws
    If i = 0 Then
        Set wsCompare = Worksheets.Add
        wsCompare.Name = "CompareSheet"
    End If
    wsCompare.Cells(1, 1) = "ID"
    wsCompare.Cells(1, 2) = "SheetName"
    wsCompare.Cells(1, 3) = "Row"
    wsCompare.Cells(1, 4) = "OnSheets"
    rwEnd = 1
    For Each ws In Worksheets
        If ws.Name <> "CompareSheet" Then
            nbrSheets = nbrSheets + 1
            ws.Select
            SheetName = ws.Name
            ws.Range(Range("A2"), Range("A" & Cells.Rows.Count).End(xlUp)).Copy
            wsCompare.Select
            rwStart = rwEnd + 1
            wsCompare.Cells(rwStart, 1).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            rwEnd = Range("A" & Cells.Rows.Count).End(xlUp).Row
            For rw = rwStart To rwEnd
                wsCompare.Cells(rw, 2) = SheetName
                wsCompare.Cells(rw, 3) = rw - rwStart + 2
            Next rw
        End If
    Next ws
    rwEnd = Range("A" & Cells.Rows.Count).End(xlUp).Row
    For rw = 2 To rwEnd
        wsCompare.Cells(rw, 4) = WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(rwEnd, 1)), Cells(rw, 1))
    Next rw
    wsCompare.Range(Cells(1, 1), Cells(rwEnd, 4)).Sort Key1:="SheetName", Order1:=xlAscending, Key2:="Row", Order2:=xlDescending, Header:=xlYes
    For rw = 2 To rwEnd
        If wsCompare.Cells(rw, 4) < nbrSheets Then
            SheetName = wsCompare.Cells(rw, 2)
            Worksheets(SheetName).Select
            Range(Cells(wsCompare.Cells(rw, 3), 1), Cells(wsCompare.Cells(rw, 3), 1)).EntireRow.Delete Shift:=xlUp
        End If
    Next rw
    Application.DisplayAlerts = False
    wsCompare.Delete
    Application.DisplayAlerts = True
    wsNow.Select
End Sub

Open in new window

RemoveItems.xlsm

sebastizz

ASKER

OK. Thanks for the script. At the moment it seems to only output 3 rows into another worksheet which I assume are the non matching rows. Would it help for me to paste an example spreadsheet so you can see how its laid out- see attached. Im not sure if your script has only enabled comparison of a few rows or not. Also should I be called the sheet to make the comparison from something else? Eventually all sheets should compare to all sheets though.

sebastizz

ASKER

Looks like the attachment didn't work so here it is again
JWControlMatchingSpreadsheet.xls

ASKER CERTIFIED SOLUTION

Ejgil Hedegaard

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

sebastizz

ASKER

Super useful answer. Really helpful and thanks for doing it so quickly