[Solved] Stop Duplicates

R

Rita_N

New member
Hello, I followed ExcelDemy's tutorial for making a search bar using VBA. I copy and pasted the workbook he provided: https://www.exceldemy.com/create-a-search-box-in-excel-for-multiple-sheets/#download

I then changed it a little to search a table instead of an array.
1721070016072.png
It now searches the full table, no matter how many rows are added, but my issue is that my table has rows with values that are the same, so the search bar will out put duplicates.
1721070355980.png
How can I make the search bar not output rows that are exactly the same?
 
Rita_N said:
Hello, I followed ExcelDemy's tutorial for making a search bar using VBA. I copy and pasted the workbook he provided: https://www.exceldemy.com/create-a-search-box-in-excel-for-multiple-sheets/#download

I then changed it a little to search a table instead of an array.
View attachment 1495
It now searches the full table, no matter how many rows are added, but my issue is that my table has rows with values that are the same, so the search bar will out put duplicates.
View attachment 1496
How can I make the search bar not output rows that are exactly the same?
Click to expand...
Hello Rita,

To avoid duplicate rows, you can add a check to see if the row has already been added. One way to do this is by using a dictionary to keep track of unique rows that have been copied.

Copy-paste the following updated VBA code:
Code: 
Sub ProjectDraft45()
    Dim Main_Sheet As String
    Dim Search_Cell As String
    Dim SearchType_Cell As String
    Dim Paste_Cell As String
    Dim Searched_Sheets As Variant
    Dim Searched_Tables As Variant
    Dim Copy_Format As Boolean
    Dim Last_Row As Long
    Dim Last_Column As Long
    Dim Used_Range As Range
    Dim Value1 As String
    Dim Case_Sensitive As Boolean
    Dim Count As Long
    Dim S As Long, i As Long, j As Long
    Dim Value2 As String
    Dim Rng As Range
    Dim Paste_Range As Range
    Dim UniqueDict As Object
    Dim RowString As String

    Main_Sheet = "Conditional"
    Search_Cell = "B10"
    SearchType_Cell = "C10"
    Paste_Cell = "B14"
    Searched_Sheets = Array("Product List")
    Searched_Tables = Array("Table1")
    Copy_Format = True
    Last_Row = Sheets(Main_Sheet).Range(Paste_Cell).End(xlDown).Row
    Last_Column = Sheets(Main_Sheet).Range(Paste_Cell).End(xlToRight).Column
    Set Used_Range = Sheets(Main_Sheet).Range(Cells(Range(Paste_Cell).Row, Range(Paste_Cell).Column), Cells(Last_Row, Last_Column))
    Used_Range.ClearContents
    Used_Range.ClearFormats
    Value1 = Sheets(Main_Sheet).Range(Search_Cell).Value
    Count = -1
    If Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case-Sensitive" Then
        Case_Sensitive = True
    ElseIf Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case-Insensitive" Then
        Case_Sensitive = False
    Else
        MsgBox ("Choose a Search Type.")
        Exit Sub
    End If
    ' Initialize the dictionary for unique rows
    Set UniqueDict = CreateObject("Scripting.Dictionary")
    For S = LBound(Searched_Sheets) To UBound(Searched_Sheets)
        Set Rng = Sheets(Searched_Sheets(S)).Range(Searched_Tables(S))
        For i = 1 To Rng.Rows.Count
            For j = 1 To Rng.Columns.Count
                Value2 = Rng.Cells(i, j).Value
                If PartialMatch(Value1, Value2, Case_Sensitive) = True Then
                    ' Create a string representation of the row
                    RowString = ""
                    For k = 1 To Rng.Columns.Count
                        RowString = RowString & Rng.Cells(i, k).Value & "|"
                    Next k
                    ' Check if the row is unique
                    If Not UniqueDict.exists(RowString) Then
                        UniqueDict.Add RowString, True
                        Count = Count + 1
                        Rng.Rows(i).Copy
                        Set Paste_Range = Sheets(Main_Sheet).Cells(Range(Paste_Cell).Row + Count, Range(Paste_Cell).Column)
                        If Copy_Format = True Then
                            Paste_Range.PasteSpecial Paste:=xlPasteAll
                        Else
                            Paste_Range.PasteSpecial Paste:=xlPasteValues
                        End If
                    End If
                End If
            Next j
        Next i
    Next S
    Application.CutCopyMode = False
End Sub
Function PartialMatch(Value1 As String, Value2 As String, Case_Sensitive As Boolean) As Boolean
    If Case_Sensitive Then
        PartialMatch = InStr(1, Value2, Value1, vbBinaryCompare) > 0
    Else
        PartialMatch = InStr(1, Value2, Value1, vbTextCompare) > 0
    End If
End Function

Updates are:
  • Used a dictionary UniqueDict is used to track unique rows.
  • Created a string representation of each row (RowString) by concatenating all the cell values in the row with a delimiter (|).
  • Before copying a row, it will check if this RowString already exists in UniqueDict. If it doesn't, the row is copied, and RowString is added to UniqueDict.
This way, unique rows will be outputted, even if your table has rows with the same values.
 
shamimarita said:
Hello Rita,

To avoid duplicate rows, you can add a check to see if the row has already been added. One way to do this is by using a dictionary to keep track of unique rows that have been copied.

Copy-paste the following updated VBA code:
Code: 
Sub ProjectDraft45()
    Dim Main_Sheet As String
    Dim Search_Cell As String
    Dim SearchType_Cell As String
    Dim Paste_Cell As String
    Dim Searched_Sheets As Variant
    Dim Searched_Tables As Variant
    Dim Copy_Format As Boolean
    Dim Last_Row As Long
    Dim Last_Column As Long
    Dim Used_Range As Range
    Dim Value1 As String
    Dim Case_Sensitive As Boolean
    Dim Count As Long
    Dim S As Long, i As Long, j As Long
    Dim Value2 As String
    Dim Rng As Range
    Dim Paste_Range As Range
    Dim UniqueDict As Object
    Dim RowString As String

    Main_Sheet = "Conditional"
    Search_Cell = "B10"
    SearchType_Cell = "C10"
    Paste_Cell = "B14"
    Searched_Sheets = Array("Product List")
    Searched_Tables = Array("Table1")
    Copy_Format = True
    Last_Row = Sheets(Main_Sheet).Range(Paste_Cell).End(xlDown).Row
    Last_Column = Sheets(Main_Sheet).Range(Paste_Cell).End(xlToRight).Column
    Set Used_Range = Sheets(Main_Sheet).Range(Cells(Range(Paste_Cell).Row, Range(Paste_Cell).Column), Cells(Last_Row, Last_Column))
    Used_Range.ClearContents
    Used_Range.ClearFormats
    Value1 = Sheets(Main_Sheet).Range(Search_Cell).Value
    Count = -1
    If Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case-Sensitive" Then
        Case_Sensitive = True
    ElseIf Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case-Insensitive" Then
        Case_Sensitive = False
    Else
        MsgBox ("Choose a Search Type.")
        Exit Sub
    End If
    ' Initialize the dictionary for unique rows
    Set UniqueDict = CreateObject("Scripting.Dictionary")
    For S = LBound(Searched_Sheets) To UBound(Searched_Sheets)
        Set Rng = Sheets(Searched_Sheets(S)).Range(Searched_Tables(S))
        For i = 1 To Rng.Rows.Count
            For j = 1 To Rng.Columns.Count
                Value2 = Rng.Cells(i, j).Value
                If PartialMatch(Value1, Value2, Case_Sensitive) = True Then
                    ' Create a string representation of the row
                    RowString = ""
                    For k = 1 To Rng.Columns.Count
                        RowString = RowString & Rng.Cells(i, k).Value & "|"
                    Next k
                    ' Check if the row is unique
                    If Not UniqueDict.exists(RowString) Then
                        UniqueDict.Add RowString, True
                        Count = Count + 1
                        Rng.Rows(i).Copy
                        Set Paste_Range = Sheets(Main_Sheet).Cells(Range(Paste_Cell).Row + Count, Range(Paste_Cell).Column)
                        If Copy_Format = True Then
                            Paste_Range.PasteSpecial Paste:=xlPasteAll
                        Else
                            Paste_Range.PasteSpecial Paste:=xlPasteValues
                        End If
                    End If
                End If
            Next j
        Next i
    Next S
    Application.CutCopyMode = False
End Sub
Function PartialMatch(Value1 As String, Value2 As String, Case_Sensitive As Boolean) As Boolean
    If Case_Sensitive Then
        PartialMatch = InStr(1, Value2, Value1, vbBinaryCompare) > 0
    Else
        PartialMatch = InStr(1, Value2, Value1, vbTextCompare) > 0
    End If
End Function

Updates are:
  • Used a dictionary UniqueDict is used to track unique rows.
  • Created a string representation of each row (RowString) by concatenating all the cell values in the row with a delimiter (|).
  • Before copying a row, it will check if this RowString already exists in UniqueDict. If it doesn't, the row is copied, and RowString is added to UniqueDict.
This way, unique rows will be outputted, even if your table has rows with the same values.
Click to expand...
This makes so much sense! Thank you; it worked perfectly!
 
Rita_N said:
This makes so much sense! Thank you; it worked perfectly!
Click to expand...
You are most welcome. Glad to hear that the solution worked perfectly. Let's continue to help each other out. If you need any further assistance, feel free to reach out. Have a great day!
 
shamimarita said:
You are most welcome. Glad to hear that the solution worked perfectly. Let's continue to help each other out. If you need any further assistance, feel free to reach out. Have a great day!
Click to expand...
Hi Shamimarita, I hope you're doing well! The code doesn't produce duplicates anymore but I also see that it doesn't reset for new searches (old search results are still present if new results don't overlap them). Is there a way to fix this?
1722459115800.png
 
Rita_N said:
Hi Shamimarita, I hope you're doing well! The code doesn't produce duplicates anymore but I also see that it doesn't reset for new searches (old search results are still present if new results don't overlap them). Is there a way to fix this?
View attachment 1519
Click to expand...
Please use this modified code. On my end, the code is clearing the previously searched content while searching for new content.

Code: 
Sub ProjectDraft45()
    Dim Main_Sheet As String
    Dim Search_Cell As String
    Dim SearchType_Cell As String
    Dim Paste_Cell As String
    Dim Searched_Sheets As Variant
    Dim Searched_Tables As Variant
    Dim Copy_Format As Boolean
    Dim Last_Row As Long
    Dim Last_Column As Long
    Dim Used_Range As Range
    Dim Value1 As String
    Dim Case_Sensitive As Boolean
    Dim Count As Long
    Dim S As Long, i As Long, j As Long
    Dim Value2 As String
    Dim Rng As Range
    Dim Paste_Range As Range
    Dim UniqueDict As Object
    Dim RowString As String


    Main_Sheet = "Conditional"
    Search_Cell = "B10"
    SearchType_Cell = "C10"
    Paste_Cell = "B14"
    Searched_Sheets = Array("Product List")
    Searched_Tables = Array("Table1")
    Copy_Format = True
    
    ' Clear the entire paste range before starting the search
    With Sheets(Main_Sheet)
        Last_Row = .Cells(.Rows.Count, .Range(Paste_Cell).Column).End(xlUp).Row
        Last_Column = .Cells(.Range(Paste_Cell).Row, .Columns.Count).End(xlToLeft).Column
        Set Used_Range = .Range(.Cells(.Range(Paste_Cell).Row, .Range(Paste_Cell).Column), .Cells(Last_Row, Last_Column))
        Used_Range.ClearContents
        Used_Range.ClearFormats
    End With


    Value1 = Sheets(Main_Sheet).Range(Search_Cell).Value
    Count = -1
    If Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case-Sensitive" Then
        Case_Sensitive = True
    ElseIf Sheets(Main_Sheet).Range(SearchType_Cell).Value = "Case-Insensitive" Then
        Case_Sensitive = False
    Else
        MsgBox ("Choose a Search Type.")
        Exit Sub
    End If


    ' Initialize the dictionary for unique rows
    Set UniqueDict = CreateObject("Scripting.Dictionary")
    For S = LBound(Searched_Sheets) To UBound(Searched_Sheets)
        Set Rng = Sheets(Searched_Sheets(S)).Range(Searched_Tables(S))
        For i = 1 To Rng.Rows.Count
            For j = 1 To Rng.Columns.Count
                Value2 = Rng.Cells(i, j).Value
                If PartialMatch(Value1, Value2, Case_Sensitive) = True Then
                    ' Create a string representation of the row
                    RowString = ""
                    For k = 1 To Rng.Columns.Count
                        RowString = RowString & Rng.Cells(i, k).Value & "|"
                    Next k
                    ' Check if the row is unique
                    If Not UniqueDict.exists(RowString) Then
                        UniqueDict.Add RowString, True
                        Count = Count + 1
                        Rng.Rows(i).Copy
                        Set Paste_Range = Sheets(Main_Sheet).Cells(Range(Paste_Cell).Row + Count, Range(Paste_Cell).Column)
                        If Copy_Format = True Then
                            Paste_Range.PasteSpecial Paste:=xlPasteAll
                        Else
                            Paste_Range.PasteSpecial Paste:=xlPasteValues
                        End If
                    End If
                End If
            Next j
        Next i
    Next S
    Application.CutCopyMode = False
End Sub


Function PartialMatch(Value1 As String, Value2 As String, Case_Sensitive As Boolean) As Boolean
    If Case_Sensitive Then
        PartialMatch = InStr(1, Value2, Value1, vbBinaryCompare) > 0
    Else
        PartialMatch = InStr(1, Value2, Value1, vbTextCompare) > 0
    End If
End Function

Download the Excel File:
 

Attachments

Okay, I decided to redo the excel and paste the code. It works but will it change again if I keep editing the table I'm pulling data from or it shouldn't happen?
 
Rita_N said:
Okay, I decided to redo the excel and paste the code. It works but will it change again if I keep editing the table I'm pulling data from or it shouldn't happen?
Click to expand...
Hello Rita_N,

The code works dynamically based on the dataset of the specified table at the time it is executed.
Once the macro is executed after making changes to the table, it should dynamically search and copy the relevant data based on the updated content. If the table structure itself is changed, the code may need to be adjusted to accommodate these changes.
Such as:
1. If the table structure (column order or the name of the table itself) changes, you might need to adjust the code accordingly to match the new structure.
2. Ensure that the search term and search type specified in the main sheet (Conditional in this case) are updated appropriately before running the macro again.
 
You must log in or register to reply here.

Online statistics

Members online
1
Guests online
10
Total visitors
11
Totals may include hidden visitors.

Forum statistics

Threads
371
Messages
1,627
Members
705
Latest member
curioso

Share this page

Back
Top