Genius Needed: code to find duplicates across tabs

[keith0528]

Greetings,

I have some code that attempts to locate duplicate entries, not within a worksheet, but across worksheets and then post sheet name of found dup in a sheet called "Instructions".

Sub SDupDel()
Dim ColumnNumber1 As Integer
Dim ColumnNumber2 As Integer
Dim Found1 As Range
Dim Found2 As Range
Dim NumtoCol As String
'Application.ScreenUpdating = False
FirstWS = 1 + 1
LastWS = Worksheets.Count - 2
Worksheets(FirstWS).Activate
Set Found1 = Cells.Find(What:="Ticket_Carrier", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
       False, SearchFormat:=False)
       
       Found1.Select
       ColumnNumber1 = Selection.Column
       NumtoCol = ConvertToLetter(ColumnNumber1)
'RI = Range("a65536").End(xlUp).Row
Log1_Range = Range(NumtoCol & "65536").End(xlUp).Row
For WkSht_Range = FirstWS To LastWS                             '<------worksheet loop
    Worksheets(WkSht_Range).Activate
    LI1 = Range(NumtoCol & "65536").End(xlUp).Row
    
    
    For row_number = 2 To Log1_Range                                    '<------row loop
        'Worksheets(FirstWS).Activate
        cell_value1 = Cells(row_number, ColumnNumber1).Value
                
        Next_Sheet = WkSht_Range + 1
        'Worksheets(NI).Activate
        Worksheets(Next_Sheet).Select '   <-------go to next worksheet
        
        Set Found2 = Cells.Find(What:="Ticket_Carrier", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
       
        Found2.Select
        ColumnNumber2 = Selection.Column
        NumtoCol = ConvertToLetter(ColumnNumber2)
        LI2 = Range(NumtoCol & "65536").End(xlUp).Row
        
        j = 2
        
            For i = 2 To LI2
            cell_value2 = Cells(i, ColumnNumber2).Value
                If cell_value2 = cell_value1 Then
                
                
                
                'Place report on Instructions tab
            Sheets("Instructions").Cells(1, 10) = "Duplicates found Across Worksheets"
            RepNum = 2
            
                Sheets("Instructions").Cells(RepNum, 10) = RowNum
                RepNum = RepNum + 1
            Else
                'don't do anything
            End If
                
                
                
                    j = j + 1
                    Worksheets(Next_Sheet).Select
                    
              Next i
            
         Worksheets(WkSht_Range).Select   'go back to 1st sheet being checked
            
    Next row_number
Next WkSht_Range
If WkSht_Range < FirstWS Then
    FirstWS = FirstWS + 1
End If
'Application.ScreenUpdating = True
End Sub

'converts column numbers to letters
Function ConvertToLetter(iCol As Integer) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function

I would be very grateful if someone could show me how this code should look.

thank you.

 

[L. Howard]

Hi keith0528,

Here is a link to a workbook.

To start with, all you have to do is click the FIND button and follow the prompts. Do that a few times trying all the options to see what you have.

You will want to parse the sheets 2 to 5 and get a feel if the code is doing what you want.

Add data as you would have in a real life workbook and check the results carefully.

Post back with any questions, I will try to answer them.

https://www.dropbox.com/s/3ob59eu0knvkypt/Find values in a list Drop Box.xlsm

Regards,
Howard

 

[ddmx488]

I would suggest a binary search. Use the below code in this manner:

Put worksheet data into arrays with the RangeToStringArray function
Sort the worksheet array with the Quicksort2D function by whichever column you'll be searching through to find data
Use binary search to return the index of the of the found result in the worksheet array

A binary search will find the results much much faster than excels built in find function.

Public Function RangeToStringArray(SourceRange As Range)

  Dim r() As Variant
  Dim r1() As String
  Dim i, j As Integer
  
  If SourceRange.Cells.Count = 0 Then
    RangeToStringArray = Nothing
    Exit Function
  End If
  
  r = SourceRange
  
  ReDim r1(LBound(r) To UBound(r), LBound(r, 2) To UBound(r, 2))
  
  For i = LBound(r) To UBound(r)
    For j = LBound(r, 2) To UBound(r, 2)
      r1(i, j) = r(i, j)
    Next j
  Next i
  
  RangeToStringArray = r1

End Function

Public Sub QuickSort2D(c() As String, SortColumn As Integer, ByVal First As Long, ByVal Last As Long, Optional Reverse As Boolean = False)

    
    '
    '  Made by Michael Ciurescu (CVMichael from vbforums.com)
    '  Original thread: [url=http://www.vbforums.com/showthread.php?t=231925]VB - Quick Sort algorithm (very fast sorting algorithm)-VBForums[/url]
    '

  Dim low As Long, high As Long
  Dim MidValue As Variant
  Dim i, j As Integer
    
  low = First
  high = Last
  MidValue = c((First + Last) \ 2, SortColumn)
  
  Do
    While c(low, SortColumn) < MidValue
        low = low + 1
    Wend
  
    While c(high, SortColumn) > MidValue
        high = high - 1
    Wend
  
    If low <= high Then
        For i = LBound(c, 2) To UBound(c, 2)
          Swap c(low, i), c(high, i)
        Next i
        
        low = low + 1
        high = high - 1
    End If
  
  Loop While low <= high
  
  If First < high Then QuickSort2D c, SortColumn, First, high
  If low < Last Then QuickSort2D c, SortColumn, low, Last
  
  If Reverse = True Then
  
    Dim a() As String
    Dim L, H As Long
    ReDim a(LBound(c) To UBound(c), LBound(c, 2) To UBound(c, 2))
    
    L = LBound(c): H = UBound(c)
    
    While L <= H
      For i = LBound(c, 2) To UBound(c, 2)
        Swap c(L, i), c(H, i)
      Next i
      L = L + 1
      H = H - 1
    Wend
    
  End If
    

End Sub

 

Private Sub Swap(ByRef a As Variant, ByRef b As Variant)


    Dim t As Variant

    t = a
    a = b
    b = t

End Sub

Public Function BinarySearch2D(strArray() As String, SearchCol As Integer, strSearch As String) As Long

  Dim lngIndex As Long
  Dim lngFirst As Long
  Dim lngLast As Long
  Dim lngMiddle As Long
  Dim bolInverseOrder As Boolean

  lngFirst = LBound(strArray)
  lngLast = UBound(strArray)
  bolInverseOrder = (strArray(lngFirst, SearchCol) > strArray(lngLast, SearchCol))
  BinarySearch2D = lngFirst - 1

  Do
    lngMiddle = (lngFirst + lngLast) \ 2
    If strArray(lngMiddle, SearchCol) = strSearch Then
    BinarySearch2D = lngMiddle
  Exit Do
    ElseIf ((strArray(lngMiddle, SearchCol) < strSearch) Xor bolInverseOrder) Then
      lngFirst = lngMiddle + 1
    Else
      lngLast = lngMiddle - 1
    End If
  Loop Until lngFirst > lngLast

End Function

 

[ddmx488]

And of course, after you find your search term, check on either side of it to see if it is not duplicated (at this point your worksheet array will be sorted alphabetically or numerically).

 

[keith0528]

Hi keith0528,

Here is a link to a workbook.

To start with, all you have to do is click the FIND button and follow the prompts. Do that a few times trying all the options to see what you have.

You will want to parse the sheets 2 to 5 and get a feel if the code is doing what you want.

Add data as you would have in a real life workbook and check the results carefully.

Post back with any questions, I will try to answer them.

https://www.dropbox.com/s/3ob59eu0knvkypt/Find%20values%20in%20a%20list%20Drop%20Box.xlsm

Regards,
Howard

Howard - 1st of all THANK YOU! That is what i'm looking for. There is only thing i'm seeing that I would change. I notice that it lists the values in the "Instructions" tab whether its a duplicate or not and I'd only want to see it if it infact did duplicate. As is, it will create an exhaustive list.

That being said I really appreciate the effort you've put into this. I took a glance at the code, didn't expect to see that much. Do you think that'd be a simple adjustment?</SPAN>

 

[L. Howard]

Okay, so with the example of values as I sent the workbook, the value "jkl" would not be listed on Instructions sheet? It only appears once on sheet 5 so do not list it.

And to be more clear, "a duplicate" refers to all sheets as a collection or on a single sheet?

Can you give me some examples scenarios where "xxx" would be listed and where it would not be listed.

Something like

abc on sheet 2 only - Don't list

abc on sheet 2 twice - List

abc on sheet 2 & 4 - list

etc...


Ref: the code. A lot of the code is not needed and can be deleted. It is there for reference to code syntax and some of it is suggestions I solicited for certain aspects of the working code. I'll clean that up in near future.

Howard

 

[L. Howard]

Hi keith0528,

I made some assumptions on what is a single occurrence value and added a snippet of code to eliminate them.

See if this is any better.


https://www.dropbox.com/s/plrlyvugibdh677/Find values Drop Box.xlsm

Howard

 

[keith0528]

Hi keith0528,

I made some assumptions on what is a single occurrence value and added a snippet of code to eliminate them.

See if this is any better.



https://www.dropbox.com/s/plrlyvugibdh677/Find%20values%20Drop%20Box.xlsm

Howard

Howard - Sorry for the late response. Thats it. You nailed it. That is exactly what i'm looking for.
2 thumbs way up!

Keith

 

[L. Howard]

You're welcome. Glad it works for you.

Regards,
Howard

 

[keith0528]

You're welcome. Glad it works for you.

Regards,
Howard

Hi Howard - at the risk of being a pain. I'm trying to tweak the code so that the array is resizable. I keep running into syntax issues. I don't know how many tabs will be in a given worksheet so it needs to be flexible. Can you assist me with that?

Option Explicit
Sub Ticket_Carrier_Dups_Array()
Sheets("Instructions").Range("X:Y").ClearContents
    Dim iRet As Integer
    Dim strPrompt As String
    Dim strTitle As String
 
    ' Promt
    strPrompt = "   Run Diagnostics for Station? " 'Columns X and Y have been cleared, do you want to " & vbCr & vbCr & _
                '"          continue and process another set of Data?"
 
    ' Dialog's Title
    strTitle = "Run Diagnostics"
 
    'Display MessageBox
    iRet = MsgBox(strPrompt, vbYesNo, strTitle)   'iRet is the value of the Yes/No answer given
 
    ' Check pressed button
   If iRet = vbNo Then
        MsgBox "Okay, Good bye"
        Exit Sub
      Else
        'MsgBox "    Yes! Let'er Rip!"
        
   End If

Dim lastRow As Long, lastRowDest As Long
Dim varSheets As Variant                '<-----array
Dim varOut As Variant
Dim i, j As Integer
Dim LastWS, StartIndex, EndIndex, LoopIndex As Integer
LastWS = Worksheets.Count
StartIndex = Sheets(1).Index + 1
EndIndex = Sheets(LastWS).Index - 2
'******************'set up headers***********************
Application.ScreenUpdating = False
ReDim varSheets(LastWS)
'For LoopIndex = StartIndex To EndIndex
'LoopIndex = StartIndex To EndIndex
 
lastRowDest = 2      '<-----this is establishing the row to start listing values
'For i = LBound(varSheets) To UBound(varSheets)
'   With Sheets(varSheets(i))   '<-------------------------subscript out of range
For i = 2 To varSheets
   
   'find column header
   
      lastRow = .Range("G" & Rows.Count).End(xlUp).Row
      varOut = .Range("G1:G" & lastRow)
      Sheets("Instructions").Cells(lastRowDest, 1) _
         .Resize(rowsize:=lastRow) = varOut
         lastRowDest = Sheets("Instructions").Range("X" & Rows.Count) _
         .End(xlUp).Row + 1
   End With
Next
'Next
Find_What_Sheet
Application.ScreenUpdating = True
MsgBox "             Done!"
End Sub
Sub Find_What_Sheet()
Dim c As Range, cc As Range, wsh As Worksheet
Dim strID As String, strOut As String
Dim LRow As Long, i As Long
Dim arrID As Variant
With Sheets("Instructions")
    LRow = .Cells(Rows.Count, 1).End(xlUp).Row
    arrID = .Range("A1:A" & LRow)
End With
For i = LBound(arrID) To UBound(arrID)
    strOut = ""
    For Each wsh In ThisWorkbook.Sheets
        If wsh.Name <> "Instructions" Then
            With wsh
                Set c = .UsedRange.Find(What:=arrID(i, 1), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole)
                If Not c Is Nothing Then
                    strOut = strOut & Replace(wsh.Name, "Sheet", "") & ", "
                End If
            End With
        End If
    Next
    
    With Sheets("Instructions")
        If Len(strOut) > 0 Then
            .Cells(i, 2) = Left(strOut, Len(strOut) - 2)
        Else
            .Cells(i, 2) = "Not found"
        End If
    End With
Next
With Sheets("Instructions").Range("X2:Y" & Cells(Rows.Count, 1).End(xlUp).Row)
  .RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
  
  For Each cc In Range("X2:Y" & Cells(Rows.Count, 1).End(xlUp).Row)
    If Len(cc.Offset(, 1)) = 1 Then
      cc.Resize(1, 2).ClearContents
    End If
  Next
  
  .HorizontalAlignment = xlLeft
End With
End Sub

thanks

 

[L. Howard]

I assume you actually mean tabs in a Workbook?

I don't know how many tabs will be in a given [COLOR=#ff0000]worksheet [/COLOR]so it needs to be flexible. Can you assist me with that?

Try something like this.

Dim wsh As Worksheet

For Each wsh In ThisWorkbook.Sheets
        If wsh.Name <> "Instructions" Then
            
          'Do stuff here

        End If
Next ' wsh

Howard