Thread: Remove duplicates from col.A and merge col.B

Hi,
Here's another solution.
I would also love to see your sample sheet.

Tony

Hi,
here is an example file.
by the way i am done with 0.5 M words. Thank you alot. It worked. You saved me at least two centuries of work! :-)

please, refer to the attachment for need modifications of the current code, in which now the coulmns C,D,E,F and G should also be included.
thanks

Hi,
Try this!

Public Sub NoDups()
'Output results to "SHEET2"
On Error Resume Next
Dim lR
Dim lR1
Dim i
Dim j
Dim k
Dim ptrCol
Dim target As String
Dim x
lR1 = 0
With Sheets("Original")
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
    If target <> .Cells(i, 1).Value Then     'First time
        target = .Cells(i, 1).Value
        lR1 = lR1 + 1
        Sheets("Sheet2").Cells(lR1, 1) = target
    End If
    For k = 2 To 7  'From column B to G
        x = Split(.Cells(i, k).Value, ";")
        For j = 0 To UBound(x)
            ptrCol = Left(x(j), 1)
            If IsError(WorksheetFunction.Find(x(j), Sheets("Sheet2").Cells(lR1, ptrCol).Value)) Then
                If Sheets("Sheet2").Cells(lR1, ptrCol).Value = "" Then
                    Sheets("Sheet2").Cells(lR1, ptrCol).Value = x(j)
                Else
                    Sheets("Sheet2").Cells(lR1, ptrCol).Value = Sheets("Sheet2").Cells(lR1, ptrCol).Value & ";" & x(j)
                End If
            End If
        Next j
    Next k
Next i
End With
End Sub

However, I think it'll take a long time to run if you have a lot of data.
Tony

Hello wali,

I made the necessary changes and ran the macro on the data in your sample workbook. The results match. Let me know if there any problems. Could you send a large sheet so I can do some time studies?

Sub CondenseWithNoDups3()

  Dim C As Long
  Dim Cx As Long
  Dim Defs As Object
  Dim I As Long
  Dim LastRow As Long
  Dim N As Long
  Dim R As Long
  Dim Rng As Range
  Dim StartCol As Variant
  Dim StartRow As Long
  Dim Str As String
  Dim Wks As Worksheet
  Dim X As Variant, Y As Variant
  
   'Setup variables
    StartCol = "A"
    StartRow = 1
    Set Wks = ActiveSheet
    
   'Define worksheet area variables
      With Wks
        C = .Cells(1, StartCol).Column
        LastRow = .Cells(Rows.Count, C).End(xlUp).Row
        LastRow = IIf(LastRow < StartRow, StartRow, LastRow)
        LastCol = .Cells(StartRow, Columns.Count).End(xlToLeft).Column
        Set Rng = .Range(.Cells(StartRow, C + 1), .Cells(LastRow, C + 1))
      End With
      
   'Create a Dictionary with case insensitive comparisons
    Set Defs = CreateObject("Scripting.Dictionary")
    Defs.CompareMode = vbTextCompare
    
    With Wks
      For Cx = C + 1 To LastCol
        For R = StartRow To LastRow
          Str = .Cells(R, Cx)
          If Str <> "" Then
            GoSub SplitData
          End If
          If .Cells(R, C) <> .Cells(R + 1, C) Then
           'Display the accumulated data less the final semi-colon
            GoSub ListDefinitions
              'If Str <> "" Then
                .Cells(R, Cx) = Left(Str, Len(Str) - 1)
              'End If
            Defs.RemoveAll
            Str = ""
          Else
           'Clear the cell's data
            .Cells(R, Cx) = ""
          End If
        Next R
      Next Cx
    End With
     
   'Delete the blank rows
    On Error Resume Next
      Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
      If Err.Number = 0 Then Rng.EntireRow.Delete Shift:=xlShiftUp
    On Error GoTo 0
    
   'Free memory
    Set Defs = Nothing
       
  Exit Sub
      
SplitData:
     'Split data where there is a semi-colon and remove any duplicates
      I = InStr(1, Str, ";")
      L = Len(Str)
        While I > 0
          X = Left(Str, I - 1)
          On Error Resume Next
            Defs.Add X, X
          L = L - I
          Str = Right(Str, L)
          I = InStr(1, Str, ";")
        Wend
      On Error Resume Next
        Defs.Add Str, Str
        Err.Clear
      On Error GoTo 0
    Return
    
ListDefinitions:
    Str = ""
    X = Defs.Keys
      For Each Y In X
       'If Str <> "" Then
          Str = Str & Y & ";"
       'End If
      Next Y
    Return
    
End Sub

Sincerely,
Leith Ross

Hello,
thank you very much you both. Both the codes work like butter. Thaaaank you veeeeery much. You both cant imagine how much i needed these macros.
take care and thanks once again

wali