Can anyone assist on amending a macro as dont seem to be doing what I want it to.

ghrek

Active Member
Joined
Jul 29, 2005
Messages
426
Hi I have the following macro but it don't seem to be doing what I want it to.

When it shows Missing or OK that's fine but its when I get duplicated in Watford and zero values.

I need it to show only the duplicated entry once as I have some that show duplicated entry twice and others only once. Also I need it to delete entries where value is ZERO on all of the entries. Like the one below they are both duplicated BUT one shows it twice and one shows once.
1382​
23​
09/01/2021​
£2.70​
DUPLICATED IN WATFORD
1382​
36​
03/12/2020​
£1.00​
DUPLICATED IN WATFORD
1382​
36​
03/12/2020​
£1.00​
DUPLICATED IN WATFORD

Macro below..
VBA Code:
 Sub compare_data()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim i As Long, j As Long, lr As Long
    
    Set sh1 = ActiveWorkbook.Sheets("TAB")
    Set sh2 = ActiveWorkbook.Sheets("WFJ")
       
    Application.ScreenUpdating = False
    lr = sh1.Range("A" & sh1.Rows.Count).End(xlUp).Row
    For i = 1 To lr
        Application.StatusBar = "Checking row : " & i & " of : " & lr
        j = Application.CountIfs(sh2.Columns("A"), sh1.Cells(i, "A").Value, sh2.Columns("B"), sh1.Cells(i, "B").Value, sh2.Columns("C"), sh1.Cells(i, "C").Value, _
            sh2.Columns("D"), sh1.Cells(i, "D").Value)
        Select Case j
        Case 0
            sh1.Cells(i, "E").Value = "MISSING"
        Case 1
            sh1.Cells(i, "E").Value = "OK"
        Case Is > 1
            sh1.Cells(i, "E").Value = "DUPLICATED IN WATFORD"
        End Select
    Next
     Last = Cells(Rows.Count, "D").End(xlUp).Row
    For i = Last To 1 Step -1
        If (Cells(i, "D").Value) = "0.00" Then
    'Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW
            Cells(i, "A").EntireRow.Delete
        End If
    Next i
  
    MsgBox "Done"
End Sub
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Change this

VBA Code:
Case Is > 1
        sh1.Cells(i, "E").Value = "DUPLICATED IN WATFORD"
End Select

To This

VBA Code:
Case Is > 1   
    If sh1.Range("A1:A" & i - 1).Find(Cells(i, 1).Value, , xlValues, xlWhole) Is Nothing Then
            sh1.Cells(i, "E").Value = "DUPLICATED IN WATFORD"
    End If 
End Select
 
Upvote 0
Changed to this and dont seem to of done nothing..

VBA Code:
Sub compare_data()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim i As Long, j As Long, lr As Long
   
    Set sh1 = ActiveWorkbook.Sheets("TAB")
    Set sh2 = ActiveWorkbook.Sheets("WFJ")
      
    Application.ScreenUpdating = False
    lr = sh1.Range("A" & sh1.Rows.Count).End(xlUp).Row
    For i = 1 To lr
        Application.StatusBar = "Checking row : " & i & " of : " & lr
        j = Application.CountIfs(sh2.Columns("A"), sh1.Cells(i, "A").Value, sh2.Columns("B"), sh1.Cells(i, "B").Value, sh2.Columns("C"), sh1.Cells(i, "C").Value, _
            sh2.Columns("D"), sh1.Cells(i, "D").Value)
        Select Case j
        Case 0
            sh1.Cells(i, "E").Value = "MISSING"
        Case 1
            sh1.Cells(i, "E").Value = "OK"
      [B][COLOR=rgb(250, 197, 28)]  Case Is > 1[/COLOR][/B]
[COLOR=rgb(250, 197, 28)][B]    If sh1.Range("A1:A" & i - 1).Find(Cells(i, 1).Value, , xlValues, xlWhole) Is Nothing Then
            sh1.Cells(i, "E").Value = "DUPLICATED IN WATFORD"
    End If
End Select[
     Last = Cells(Rows.Count, "D").End(xlUp).Row
    For i = Last To 1 Step -1
        If (Cells(i, "D").Value) = "0.00" Then
    'Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW
            Cells(i, "A").EntireRow.Delete
        End If
    Next i
     MsgBox "Done"
End Sub
 
Upvote 0
If you want to highlight font, you have to use the "Rich" code tags for the code. In my test set up , i put duplicates in conlumn A then ran a snippet to loop down column A and evaluate if there was a previous entry for that value, and if so it would not enter the text in Column E, otherwise it will enter the text in column E. The statement worked as expected in the test set up. What that means is that you would have duplicates that have nothing in column E except for the firt occurence. So if you run the code and then check a couple of know duplicates to see if the first occxurrence has the text in column E, but the other(s) do not, then the code is working as expected.
 
Upvote 0
The highlighting was an error by me, the duplicate entry must be right across columns
A-D and not just column A as there will be loads of duplicate numbers in that. So therefore if there a entry exactly the same in columns A-D then I need 1 deleted. Sorry not specific earlier.
 
Upvote 0
So therefore if there a entry exactly the same in columns A-D then I need 1 deleted. Sorry not specific earlier.

Can you post a better example of what you are calling a duplicate? The image in the OP only shows vertical duplicates, not horizontal. And do you want to only compare a single row at a time for duplicates or are you expecting to compare, for example, cell A5 To All of columns B, C and D? A before and after illustration is needed to understand what you are trying to accomplish.
 
Upvote 0
My apologies I was looking at it the wrong way. Its ok thanks for help,
SORRY just found one other thing...

I also need it to mark up on page called WFD when the data is in the tab called WFD but NOT in Tab called TAB. Then I need it marked on WFD tab "MISSING FROM TABLEAU"

Workbook im using in this one drive file.

 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,725
Members
448,294
Latest member
jmjmjmjmjmjm

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top