Macro dont seem to be pointing out duplicated data

G

ghrek

Active Member
Joined
Jul 29, 2005
Messages
426
First of all apologies if seemed to be duplicated on another forum but it don't seem to of posted on it and thus why coming to you.

UPDATE:-TOOK ITS TIME UPLOADING AND HERE IT IS...

Macro is not pointing out duplicated entries [SOLVED]

Hi First of all apologies but I posted on another forum too as thought it hadnt posted on here originally. Heres link https://www.mrexcel.com/board/threads/macro-dont-seem-to-be-pointing-out-duplicated-data.1162766/ I was given a macro by an ex work colleague but it dont seem to be doing...
www.excelforum.com


I was given the macro below of which should show up when missing from TAB or MISSING FROM STN of which works correctly. I had it given to me by a old colleague who now left.

I thought it was supposed to look in sheets called TAB and STN and if there any duplicated entries it list them in sheet 3.

Macro and workbook enclosed with a simplified description. Any Ideas?

OneDrive

Sign in to your OneDrive cloud storage and Office Online.
1drv.ms 1drv.ms

VBA Code: 
Option Explicit
Sub CompareSheets()
Dim wsTAB As Worksheet
Dim wsSTN As Worksheet
Dim ws3 As Worksheet
Dim lngRow As Long
Dim lngLastRow1 As Long
Dim lngLastRow2 As Long
Dim lngNextRow As Long
Dim colTAB As Collection
Dim colSTN As Collection
Dim lngTAB As Long
Dim lngSTN As Long
Dim lngNR3 As Long
Dim rngFound As Range
Dim strParts() As String
Dim rng As Range
Dim lngArea As Long
Dim lngCell As Long
Const COL_CONCAT = "X"

Set wsTAB = ThisWorkbook.Worksheets("TAB")
Set wsSTN = ThisWorkbook.Worksheets("STN")
Set ws3 = ThisWorkbook.Worksheets("Sheet3")
ws3.UsedRange.Cells.ClearContents

With wsTAB
    Application.ScreenUpdating = False
    'Insert a blank row at the top of each for filtering purposes
    .Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    wsSTN.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    lngNextRow = 1
  
    lngLastRow1 = .Cells(Rows.Count, 1).End(xlUp).Row
    For lngRow = 2 To lngLastRow1
        lngNextRow = lngNextRow + 1
        .Cells(lngNextRow, COL_CONCAT) = Join(.Range("A" & lngRow & ":D" & lngRow))
    Next
  
    ' Do the same for the STN sheet
    lngLastRow2 = wsSTN.Cells(Rows.Count, 1).End(xlUp).Row
    lngNextRow = 1
    For lngRow = 2 To lngLastRow2
        lngNextRow = lngNextRow + 1
        wsSTN.Cells(lngNextRow, COL_CONCAT) = Join(wsSTN.Range("A" & lngRow & ":D" & lngRow))
    Next
  
    ' Create a collection of unique concatenated values
    Set colTAB = New Collection
    For lngRow = 2 To lngLastRow1
        On Error Resume Next
        colTAB.Add .Cells(lngRow, COL_CONCAT), CStr(.Cells(lngRow, COL_CONCAT))
        On Error GoTo 0
    Next
  
    ' And the same for STN
    Set colSTN = New Collection
    For lngRow = 2 To lngLastRow2
        On Error Resume Next
        colSTN.Add wsSTN.Cells(lngRow, COL_CONCAT), CStr(wsSTN.Cells(lngRow, COL_CONCAT))
        On Error GoTo 0
    Next

    ' Find duplicates by filtering both tabs and comparing the two counts
    ' of visible rows
    For lngTAB = 1 To colTAB.Count
        ' Clear any previous autofiltering
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
        .Range(.Cells(1, COL_CONCAT), .Cells(lngLastRow1, COL_CONCAT)).AutoFilter Field:=1, Criteria1:=colTAB(lngTAB)
      
        On Error Resume Next
        wsSTN.ShowAllData
        On Error GoTo 0

        wsSTN.Range(wsSTN.Cells(1, COL_CONCAT), wsSTN.Cells(lngLastRow2, COL_CONCAT)).AutoFilter Field:=1, Criteria1:=colTAB(lngTAB)

        Select Case True
            Case .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count < _
                  wsSTN.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
                  ' STN count is greater so it's a duplicate
                lngNR3 = lngNR3 + 1
                strParts = Split(colTAB(lngTAB), "|")
                With ws3
                    .Cells(lngNR3, "A") = strParts(0)
                    .Cells(lngNR3, "B") = strParts(1)
                    .Cells(lngNR3, "C") = strParts(2)
                    .Cells(lngNR3, "D") = strParts(3)
                    .Cells(lngNR3, "E") = "DUPLICATED"
                End With
        End Select
  
        ' Find Nissing
        ' Find those in TAB that aren't in STN
        Set rng = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
'        If Left(colTAB(lngTAB), 4) = "9755" Then
'            Stop
'        End If

        For lngArea = 1 To rng.Areas.Count
            For lngCell = 1 To rng.Areas(lngArea).Cells.Count
                If Not IsEmpty(rng.Areas(lngArea).Cells(lngCell).Value) Then
                    Set rngFound = wsSTN.Columns(COL_CONCAT).Find(What:=rng.Areas(lngArea).SpecialCells(xlCellTypeVisible).Cells(lngCell).Value, LookIn:=xlFormulas, _
                                   LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                   MatchCase:=False, SearchFormat:=False)
                    If wsSTN.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
                        ' A count of 1 indicates that only the first row (which is blank) is visible
                        strParts = Split(rng.Areas(lngArea).Cells(lngCell).Value, "|")
                        lngNR3 = lngNR3 + 1
                        With ws3
                            .Cells(lngNR3, "A") = strParts(0)
                            .Cells(lngNR3, "B") = strParts(1)
                            .Cells(lngNR3, "C") = strParts(2)
                            .Cells(lngNR3, "D") = strParts(3)
                            .Cells(lngNR3, "E") = "MISSING FROM STN"
                        End With
                    End If
                End If
            Next
        Next
    Next
    ' Finally, find those in STN that aren't in TAB
    For lngSTN = 1 To colSTN.Count
        ' Clear any previous autofiltering
        On Error Resume Next
        wsSTN.ShowAllData
        On Error GoTo 0
        wsSTN.Range(wsSTN.Cells(1, COL_CONCAT), wsSTN.Cells(lngLastRow1, COL_CONCAT)).AutoFilter Field:=1, Criteria1:=colSTN(lngSTN)
      
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0

        .Range(.Cells(1, COL_CONCAT), .Cells(lngLastRow2, COL_CONCAT)).AutoFilter Field:=1, Criteria1:=colSTN(lngSTN)
        Set rng = wsSTN.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
        For lngArea = 1 To rng.Areas.Count
            For lngCell = 1 To rng.Areas(lngArea).Cells.Count
                If Not IsEmpty(rng.Areas(lngArea).Cells(lngCell).Value) Then
                    Set rngFound = .Columns(COL_CONCAT).Find(What:=rng.Areas(lngArea).SpecialCells(xlCellTypeVisible).Cells(lngCell).Value, LookIn:=xlFormulas, _
                                   LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                   MatchCase:=False, SearchFormat:=False)
                    If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
                        ' A count of 1 indicates that only the first row (which is blank) is visible
                        strParts = Split(rng.Areas(lngArea).Cells(lngCell).Value, "|")
                        lngNR3 = lngNR3 + 1
                        With ws3
                            .Cells(lngNR3, "A") = strParts(0)
                            .Cells(lngNR3, "B") = strParts(1)
                            .Cells(lngNR3, "C") = strParts(2)
                            .Cells(lngNR3, "D") = strParts(3)
                            .Cells(lngNR3, "E") = "MISSING FROM TAB"
                        End With
                    End If
                End If
            Next
        Next
    Next
     
    .Columns(COL_CONCAT).AutoFilter
    wsSTN.Columns(COL_CONCAT).AutoFilter
  
    ws3.Activate
              
    ' Clean up
    .Cells(1, "A").EntireRow.Delete
    wsSTN.Cells(1, "A").EntireRow.Delete
    .Columns(COL_CONCAT).Cells.ClearContents
    wsSTN.Columns(COL_CONCAT).Cells.ClearContents
    Set colSTN = Nothing
    Set colTAB = Nothing
    Set wsTAB = Nothing
    Set wsSTN = Nothing
    Set ws3 = Nothing
  
    Application.ScreenUpdating = True

End With
End Sub
Public Function Join(rng As Range) As String
    Dim cel As Range
  
    For Each cel In rng
        Join = Join & cel.Text & "|"
    Next cel
    ' remove the last delimiter
    Join = Left(Join, Len(Join) - Len("|"))
  
    If Len(Join) < 8 Then
        MsgBox "Invalid data found at row " & rng.Row & " in worksheet " & rng.Worksheet.Name
        Exit Function
    End If
End Function
 
Last edited:

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
Use this to find duplicates

VBA Code: 
Sub FindDupe()

Dim eRow As Long
Dim rngList As Range
Dim cell As Variant
Dim dList As Object
Dim wsTAB As Worksheet, wsSTN As Worksheet, ws3 As Worksheet

Set wsTAB = ActiveWorkbook.Sheets("TAB")
Set wsSTN = ActiveWorkbook.Sheets("STN")
Set ws3 = ActiveWorkbook.Sheets("Sheet3")
Set dList = CreateObject("Scripting.Dictionary")

Set rngList = wsTAB.Range("A1", wsTAB.Cells(wsTAB.Rows.Count, "A").End(xlUp))
For Each cell In rngList
    If Not dList.exists(cell.Value & cell.Offset(0, 1).Value & cell.Offset(0, 2).Value & cell.Offset(0, 3).Value) Then
        dList.Add cell.Value & cell.Offset(0, 1).Value & cell.Offset(0, 2).Value & cell.Offset(0, 3).Value, cell.Row
    Else
        wsTAB.Range("A" & cell.Row, "D" & cell.Row).Interior.ColorIndex = 6
        wsTAB.Range("A" & cell.Row, "D" & cell.Row).Copy
        eRow = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row + 1
        ws3.Range("A" & eRow).PasteSpecial (xlPasteValues)
        ws3.Range("E" & eRow) = "DUPLICATE IN TAB"
    End If
Next

dList.RemoveAll
Set rngList = wsSTN.Range("A1", wsSTN.Cells(wsSTN.Rows.Count, "A").End(xlUp))
For Each cell In rngList
    If Not dList.exists(cell.Value & cell.Offset(0, 1).Value & cell.Offset(0, 2).Value & cell.Offset(0, 3).Value) Then
        dList.Add cell.Value & cell.Offset(0, 1).Value & cell.Offset(0, 2).Value & cell.Offset(0, 3).Value, cell.Row
    Else
        wsSTN.Range("A" & cell.Row, "D" & cell.Row).Interior.ColorIndex = 6
        wsSTN.Range("A" & cell.Row, "D" & cell.Row).Copy
        eRow = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row + 1
        ws3.Range("A" & eRow).PasteSpecial (xlPasteValues)
        ws3.Range("E" & eRow) = "DUPLICATE IN STN"
    End If
Next

End Sub
 
Upvote 0
@Zot has just provided code that looks far more efficient than yours.

FYI, it looks like the problem with your current code is this line, where the logic is not correct:

VBA Code: 
Case .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count < _
      wsSTN.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
      ' STN count is greater so it's a duplicate

Assuming by duplicate, you mean a match across the two sheets TAB and STN, the test here should be:

Code: 
Case wsSTN.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1

If there is any line here in the filtered results, i.e. in addition to the one header line, it is necessarily a duplicate.

I don't know what you want to do about identifying records duplicated multiple times?
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,214,653
Messages
6,120,751
Members
448,989
Latest member
mariah3

Share this page

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