Find Partial Duplicate values in a column

leeandoona · Feb 25, 2019

I have an annoying problem I never seem to solve properly and today I've had another bash at it and I still can't figure out the best way forward. The problem is I have a very large list of data that contains columns that have partial duplicates that I need to identify, and then turn into 'unique' records. Unfortunately the duplicate values can occur randomly at the front, back of middle of the text string and can be either words or numbers or both! For example, here is a sample of what I've got to work with;

SANTAS LITTLE HELPER (116cm)

SANTAS LITTLE HELPER (128cm)

SANTAS LITTLE HELPER (140cm)

PETTICOAT WHITE - ONE SIZE

PETTICOAT RED - ONE SIZE

PETTICOAT BLACK - ONE SIZE

DEATHLY GRIM REAPER (S)

DEATHLY GRIM REAPER (M)

DEATHLY GRIM REAPER (L)

DEATHLY GRIM REAPER (XL)

COLOUR CHANGING CRYSTAL BALL

DEATHLY GRIM REAPER (128cm)

DEATHLY GRIM REAPER (140cm)

DEATHLY GRIM REAPER (158cm)

and here's what it ought to look like when I've identified and removed the duplicates;

Description

SANTAS LITTLE HELPER

PETTICOAT - ONE SIZE

DEATHLY GRIM REAPER

COLOUR CHANGING CRYSTAL BALL

DEATHLY GRIM REAPER

As you can see, this makes a lookup unlikely to work well and fuzzylookup isn't really working properly either. I need to essentially identify the duplicates and remove the differentials.

Is there any VBA that will solve this, or even get close would help? Thanks v much

leeandoona · Feb 26, 2019

Akuini said:
I suggest you get help from another forum that has Word Help section, such as:
http://www.vbaexpress.com/forum/forumdisplay.php?20-Word-Help
because actually Word is better than Excel in dealing with words & character, so I believe you get better chance to get a solution.

Thats being said, if your data is not sensitive, you could upload your workbook (without sensitive data) somewhere (maybe to dropbox.com or google drive)? Then put the link here. Maybe someone here can find a solution.

Actually how do you manually determine the first part? Is it if some words (maybe 1,2 ,3 or 4 words) in the beginning of some cells are the same then those are the first part & considered as duplicate?

Thanks for the tip on the word link. Will try that. Never really gave that much thought to be honest. I could also upload the data, it is not really sensitive.

As for how I determine the first part it is pretty much as you suggest, the point at which the words no longer match is typically the point at which you've found an entry that is essentially a duplicate with a variant value. For example;

monkey likes cheese LOTS
monkey likes cheese SOME
monkey likes cheese LITTLE
Horse like hay ALWAYS

'monkey likes cheese' (is the duplicate or Parent entry) LOTS, SOME & LITTLE (are the variants or children entries that I'd like sat in the column next to the parent). 'Horse like hay ALWAYS' is unique and therefore remains as it is. So what I look for is multiple instances of the same words that are then followed by variable instances. That's how the 'Parent/child' relationship is worked out. Data that appears as a solitary instance with no variables is simply left as it is. So this is why I keep following the loop, count, match route which is possibly not the way to go as you suggest.

I had (almost) figured out a way using excel that was rather clunky and long handed that worked something like this:

Text to columns THEN Textjoin column 1&2 THEN Textjoin that result with column 3 and repeat this so that the split out data is gradually put back together word by word/character. THEN COUNTIF each concatenated cell. At some point the count will then remain the same as all the words will be back together. The point at which the LAST count differed from the next is equal to the data that contained the last exact amount of words and should be equal to the point where the data changes. Then simply SWITCHIF the results to point to the corresponding cell of data. Unfortunately its flawed because the data can have the same count but contain different variables that happen to be the same character length. e.g.

monkey likes cheese ONE
monkey likes cheese TWO

So both get identified using that flawed method as being the same ...Was worth a try though!

leeandoona · Feb 26, 2019

sheetspread said:
It can also change each term to the first in the group, but you seem to only want common strings.

Unfortunately I'm not performing a 'lookup' and have no comparison data set to run against. So Fuzzy won't work unless there is a way it can do a Hlookup against itself?

leeandoona · Feb 26, 2019

leeandoona said:
Thanks for the tip on the word link. Will try that. Never really gave that much thought to be honest. I could also upload the data, it is not really sensitive.

So attached is an example of the data. Column A are unique ID's that don't contain any obvious methods for identifying 'Unique' records or 'Variant' records. Column B contains the Data. I have also included an example of what I'm trying to achieve on the same worksheet.

UID Dataset 1 UID Example Parent Example Child
exmp/00005 SANTAS LITTLE HELPER (116cm) exmp/00005 SANTAS LITTLE HELPER (116cm)
exmp/00006 SANTAS LITTLE HELPER (128cm) exmp/00006 SANTAS LITTLE HELPER (128cm)
exmp/00007 SANTAS LITTLE HELPER (140cm) exmp/00007 SANTAS LITTLE HELPER (140cm)
exmp/00008 PETTICOAT WHITE - ONE SIZE exmp/00008 PETTICOAT - ONE SIZE WHITE
exmp/00009 PETTICOAT RED - ONE SIZE exmp/00009 PETTICOAT - ONE SIZE RED
exmp/00010 PETTICOAT BLACK - ONE SIZE exmp/00010 PETTICOAT - ONE SIZE BLACK
exmp/00011 DEATHLY GRIM REAPER (S) exmp/00011 DEATHLY GRIM REAPER (S)
exmp/00012 DEATHLY GRIM REAPER (M) exmp/00012 DEATHLY GRIM REAPER (M)
exmp/00013 DEATHLY GRIM REAPER (L) exmp/00013 DEATHLY GRIM REAPER (L)
exmp/00014 DEATHLY GRIM REAPER (XL) exmp/00014 DEATHLY GRIM REAPER (XL)
exmp/00015 COLOUR CHANGING CRYSTAL BALL exmp/00015 COLOUR CHANGING CRYSTAL BALL
exmp/00016 DEATHLY GRIM REAPER (128cm) exmp/00016 DEATHLY GRIM REAPER (128cm)
exmp/00017 DEATHLY GRIM REAPER (140cm) exmp/00017 DEATHLY GRIM REAPER (140cm)
exmp/00018 DEATHLY GRIM REAPER (158cm) exmp/00018 DEATHLY GRIM REAPER (158cm)
exmp/00021 CAT (S) exmp/00021 CAT (S)
exmp/00022 CAT (M) exmp/00022 CAT (M)
exmp/00023 CAT (L) exmp/00023 CAT (L)
exmp/00025 HOLY MARY (116cm) exmp/00025 HOLY MARY (116cm)
exmp/00026 HOLY MARY (128cm) exmp/00026 HOLY MARY (128cm)
exmp/00027 HOLY MARY (140cm) exmp/00027 HOLY MARY (140cm)

<colgroup><col><col><col span="4"><col><col></colgroup><tbody>
</tbody>

ZVI · Feb 27, 2019

Hi,

Use the below code:

Rich (BB code):

Option Explicit
Option Compare Text
 
Sub Main()
 
  Dim a(), b()
  Dim i As Long, j As Long, k As Long, n As Long
  Dim Rng As Range
  Dim s As String, s1 As String, s2 As String
  Dim w1, w2
 
  ' Set data range A:D
  With ActiveSheet.UsedRange
    Set Rng = .Offset(1).Resize(.Rows.Count - 1).Columns("A:D")
  End With
 
  ' Normalize Dataset
  a() = Rng.Columns("B").Value
  For i = 1 To UBound(a)
    a(i, 1) = Join(TxtToArray(a(i, 1)))
  Next
 
  ' Disable screen updating
  Application.ScreenUpdating = False
 
  ' Sord Rng by Dataset
  With Rng
    .Columns("C").Value = a()
    .Sort .Cells(1, "C"), xlAscending, Header:=xlNo
  End With
 
  ' Convert normalized & sorted Dataset to array
  a() = Rng.Columns("C:D").Value
  For i = 1 To UBound(a)
    a(i, 2) = TxtToArray(a(i, 1))
  Next
 
  ' Do main
  ReDim b(1 To UBound(a), 1 To 2)
  i = 1
  j = i + 1
  Do
    s = vbNullString
    k = 0
    While a(i, 2)(k) = a(j, 2)(k)
      s = s & a(i, 2)(k) & " "
      k = k + 1
    Wend
    If k > 0 Then
      If k <= UBound(a(i, 2)) Then
        s1 = ""
        For n = k + 1 To UBound(a(i, 2))
          s1 = s1 & a(i, 2)(n) & " "
        Next
        s1 = RTrim$(s1)
        s2 = ""
        For n = k + 1 To UBound(a(j, 2))
          s2 = s2 & a(j, 2)(n) & " "
        Next
        s2 = RTrim$(s2)
        If Len(s1) > 0 And s1 = s2 Then
          If j = i + 1 Then b(i, 1) = s & s1 '
          b(j, 1) = b(i, 1)
          b(i, 2) = a(i, 2)(k)
          b(j, 2) = a(j, 2)(k)
        Else
          b(i, 1) = RTrim$(s)
          b(j, 1) = b(i, 1)
          b(i, 2) = a(i, 2)(k) & s1
          b(j, 2) = a(j, 2)(k) & s2
        End If
        j = j + 1
        If j <= UBound(a) Then
          If Not a(j, 1) Like s & "*" Then
            i = j
            j = i + 1
          End If
        End If
      Else
        b(i, 1) = a(i, 2)
        i = j
        j = i + 1
      End If
    Else
      b(i, 1) = a(i, 1)
      i = j
      j = i + 1
    End If
  Loop While j <= UBound(a)
 
  ' Create result
  Rng.Columns("C:D").Value = b()
 
  ' Sort Rng by UID
  With Rng
    .Sort .Cells(1, "A"), xlAscending, Header:=xlNo
  End With
 
  ' Enable screen updating
  Application.ScreenUpdating = True
 
End Sub
 
Function TxtToArray(Txt) As Variant
  Dim a, i As Long, j As Long, s As String
  Dim RegEx As Object
  If RegEx Is Nothing Then
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
    RegEx.Pattern = "[.,!?:;_\-]"
  End If
  s = RegEx.Replace(Txt, " ")
  If s Like "*(* *)*" Then
    i = InStr(s, "(")
    While i > 0
      j = InStr(i + 1, s, ")")
      If j > 1 Then
        s = Mid$(s, 1, i) & Replace(Mid$(s, i + 1, j - i - 1), " ", "") & Mid$(s, j)
        i = InStr(j + 1, s, "(")
      Else
        i = 0
      End If
    Wend
  End If
  a = Split(s)
  j = 0
  For i = 0 To UBound(a)
    If Len(a(i)) > 0 Then
      a(j) = a(i)
      j = j + 1
    End If
  Next
  If j - 1 < UBound(a) Then ReDim Preserve a(0 To j - 1)
  TxtToArray = a
End Function

The layout of input/output:

Book1

A

B

C

D

1

UID

Dataset 1

Parent (normalized)

Child (normalized)

2

exmp/00005

SANTAS LITTLE HELPER (116cm)

SANTAS LITTLE HELPER

(116cm)

3

exmp/00006

SANTAS LITTLE HELPER (128cm)

SANTAS LITTLE HELPER

(128cm)

4

exmp/00007

SANTAS LITTLE HELPER (140cm)

SANTAS LITTLE HELPER

(140cm)

5

exmp/00008

PETTICOAT WHITE - ONE SIZE

PETTICOAT ONE SIZE

WHITE

6

exmp/00009

PETTICOAT RED - ONE SIZE

PETTICOAT ONE SIZE

RED

7

exmp/00010

PETTICOAT BLACK - ONE SIZE

PETTICOAT ONE SIZE

BLACK

8

exmp/00011

DEATHLY GRIM REAPER (S)

DEATHLY GRIM REAPER

(S)

9

exmp/00012

DEATHLY GRIM REAPER (M)

DEATHLY GRIM REAPER

(M)

10

exmp/00013

DEATHLY GRIM REAPER (L)

DEATHLY GRIM REAPER

(L)

11

exmp/00014

DEATHLY GRIM REAPER (XL)

DEATHLY GRIM REAPER

(XL)

12

exmp/00015

COLOUR CHANGING CRYSTAL BALL

13

exmp/00016

DEATHLY GRIM REAPER (128cm)

DEATHLY GRIM REAPER

(128cm)

14

exmp/00017

DEATHLY GRIM REAPER (140cm)

DEATHLY GRIM REAPER

(140cm)

15

exmp/00018

DEATHLY GRIM REAPER (158cm)

DEATHLY GRIM REAPER

(158cm)

16

exmp/00021

CAT (S)

CAT

(S)

17

exmp/00022

CAT (M)

CAT

(M)

18

exmp/00023

CAT (L)

CAT

(L)

19

exmp/00025

HOLY MARY (116cm)

HOLY MARY

(116cm)

20

exmp/00026

HOLY MARY (128cm)

HOLY MARY

(128cm)

21

exmp/00027

HOLY MARY (140cm)

HOLY MARY

(140cm)

Sheet1

Regards

leeandoona · Feb 27, 2019

ZVI said:

Hi,

Use the below code:

Rich (BB code):

Option Explicit
Option Compare Text
 
Sub Main()
 
  Dim a(), b()
  Dim i As Long, j As Long, k As Long, n As Long
  Dim Rng As Range
  Dim s As String, s1 As String, s2 As String
  Dim w1, w2
 
  ' Set data range A:D
  With ActiveSheet.UsedRange
    Set Rng = .Offset(1).Resize(.Rows.Count - 1).Columns("A:D")
  End With
 
  ' Normalize Dataset
  a() = Rng.Columns("B").Value
  For i = 1 To UBound(a)
    a(i, 1) = Join(TxtToArray(a(i, 1)))
  Next
 
  ' Disable screen updating
  Application.ScreenUpdating = False
 
  ' Sord Rng by Dataset
  With Rng
    .Columns("C").Value = a()
    .Sort .Cells(1, "C"), xlAscending, Header:=xlNo
  End With
 
  ' Convert normalized & sorted Dataset to array
  a() = Rng.Columns("C:D").Value
  For i = 1 To UBound(a)
    a(i, 2) = TxtToArray(a(i, 1))
  Next
 
  ' Do main
  ReDim b(1 To UBound(a), 1 To 2)
  i = 1
  j = i + 1
  Do
    s = vbNullString
    k = 0
    While a(i, 2)(k) = a(j, 2)(k)
      s = s & a(i, 2)(k) & " "
      k = k + 1
    Wend
    If k > 0 Then
      If k <= UBound(a(i, 2)) Then
        s1 = ""
        For n = k + 1 To UBound(a(i, 2))
          s1 = s1 & a(i, 2)(n) & " "
        Next
        s1 = RTrim$(s1)
        s2 = ""
        For n = k + 1 To UBound(a(j, 2))
          s2 = s2 & a(j, 2)(n) & " "
        Next
        s2 = RTrim$(s2)
        If Len(s1) > 0 And s1 = s2 Then
          If j = i + 1 Then b(i, 1) = s & s1 '
          b(j, 1) = b(i, 1)
          b(i, 2) = a(i, 2)(k)
          b(j, 2) = a(j, 2)(k)
        Else
          b(i, 1) = RTrim$(s)
          b(j, 1) = b(i, 1)
          b(i, 2) = a(i, 2)(k) & s1
          b(j, 2) = a(j, 2)(k) & s2
        End If
        j = j + 1
        If j <= UBound(a) Then
          If Not a(j, 1) Like s & "*" Then
            i = j
            j = i + 1
          End If
        End If
      Else
        b(i, 1) = a(i, 2)
        i = j
        j = i + 1
      End If
    Else
      b(i, 1) = a(i, 1)
      i = j
      j = i + 1
    End If
  Loop While j <= UBound(a)
 
  ' Create result
  Rng.Columns("C:D").Value = b()
 
  ' Sort Rng by UID
  With Rng
    .Sort .Cells(1, "A"), xlAscending, Header:=xlNo
  End With
 
  ' Enable screen updating
  Application.ScreenUpdating = True
 
End Sub
 
Function TxtToArray(Txt) As Variant
  Dim a, i As Long, j As Long, s As String
  Dim RegEx As Object
  If RegEx Is Nothing Then
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
    RegEx.Pattern = "[.,!?:;_\-]"
  End If
  s = RegEx.Replace(Txt, " ")
  If s Like "*(* *)*" Then
    i = InStr(s, "(")
    While i > 0
      j = InStr(i + 1, s, ")")
      If j > 1 Then
        s = Mid$(s, 1, i) & Replace(Mid$(s, i + 1, j - i - 1), " ", "") & Mid$(s, j)
        i = InStr(j + 1, s, "(")
      Else
        i = 0
      End If
    Wend
  End If
  a = Split(s)
  j = 0
  For i = 0 To UBound(a)
    If Len(a(i)) > 0 Then
      a(j) = a(i)
      j = j + 1
    End If
  Next
  If j - 1 < UBound(a) Then ReDim Preserve a(0 To j - 1)
  TxtToArray = a
End Function

The layout of input/output:

	A	B	C	D
1	UID	Dataset 1	Parent (normalized)	Child (normalized)
2	exmp/00005	SANTAS LITTLE HELPER (116cm)	SANTAS LITTLE HELPER	(116cm)
3	exmp/00006	SANTAS LITTLE HELPER (128cm)	SANTAS LITTLE HELPER	(128cm)
4	exmp/00007	SANTAS LITTLE HELPER (140cm)	SANTAS LITTLE HELPER	(140cm)
5	exmp/00008	PETTICOAT WHITE - ONE SIZE	PETTICOAT ONE SIZE	WHITE
6	exmp/00009	PETTICOAT RED - ONE SIZE	PETTICOAT ONE SIZE	RED
7	exmp/00010	PETTICOAT BLACK - ONE SIZE	PETTICOAT ONE SIZE	BLACK
8	exmp/00011	DEATHLY GRIM REAPER (S)	DEATHLY GRIM REAPER	(S)
9	exmp/00012	DEATHLY GRIM REAPER (M)	DEATHLY GRIM REAPER	(M)
10	exmp/00013	DEATHLY GRIM REAPER (L)	DEATHLY GRIM REAPER	(L)
11	exmp/00014	DEATHLY GRIM REAPER (XL)	DEATHLY GRIM REAPER	(XL)
12	exmp/00015	COLOUR CHANGING CRYSTAL BALL	COLOUR CHANGING CRYSTAL BALL
13	exmp/00016	DEATHLY GRIM REAPER (128cm)	DEATHLY GRIM REAPER	(128cm)
14	exmp/00017	DEATHLY GRIM REAPER (140cm)	DEATHLY GRIM REAPER	(140cm)
15	exmp/00018	DEATHLY GRIM REAPER (158cm)	DEATHLY GRIM REAPER	(158cm)
16	exmp/00021	CAT (S)	CAT	(S)
17	exmp/00022	CAT (M)	CAT	(M)
18	exmp/00023	CAT (L)	CAT	(L)
19	exmp/00025	HOLY MARY (116cm)	HOLY MARY	(116cm)
20	exmp/00026	HOLY MARY (128cm)	HOLY MARY	(128cm)
21	exmp/00027	HOLY MARY (140cm)	HOLY MARY	(140cm)

Sheet1

Regards

Wow!

I'm trying it now. Initially I ran this over the entire dataset which is over 25,000 lines and it eventually stopped with an error that needed debug. I'm guessing though it was just too large. I'll try it over smaller subsets and get back to you with results! Thank you ever so much for making such an effort for me, it is much appreciated.

leeandoona · Feb 27, 2019

leeandoona said:
Wow! I'm trying it now. Initially I ran this over the entire dataset which is over 25,000 lines and it eventually stopped with an error that needed debug. I'm guessing though it was just too large. I'll try it over smaller subsets and get back to you with results! Thank you ever so much for making such an effort for me, it is much appreciated.

Okay, so debug message is "runtime error '9' subscript out of range" and the debug highlights;

While a(i, 2)(k) = a(j, 2)(k)

I tried over a range of 1,000 and then over 100 rows just to make sure. Same error message "runtime error '9' subscript out of range. I'm running in same input/output format of coumns A through D. Any idea what I might be doing wrong?

ZVI · Feb 27, 2019

Code was developed for the posted data structure. And it works with it - try using the posted data.
There is no limitation in amount of data rows for the code.
The below is a bit enhanced version for some other data structures.
If it does not work then you may send me actual (not sensitive) data for testing other structures - just PM me to get my email.

Rich (BB code):

Option Explicit
Option Compare Text
 
Sub Main()
 
  Dim a(), b()
  Dim i As Long, j As Long, k As Long, n As Long, m As Long
  Dim Rng As Range
  Dim s As String, s1 As String, s2 As String
 
  ' Set data range A:D
  With ActiveSheet.UsedRange
    Set Rng = .Offset(1).Resize(.Rows.Count - 1).Columns("A:D")
  End With
 
  ' Normalize Dataset
  a() = Rng.Columns("B").Value
  For i = 1 To UBound(a)
    a(i, 1) = Join(TxtToArray(a(i, 1)))
  Next
 
  ' Disable screen updating
  Application.ScreenUpdating = False
 
  ' Sord Rng by Dataset
  With Rng
    .Columns("C").Value = a()
    .Sort .Cells(1, "C"), xlAscending, Header:=xlNo
  End With
 
  ' Convert normalized & sorted Dataset to array
  a() = Rng.Columns("C:D").Value
  For i = 1 To UBound(a)
    a(i, 2) = TxtToArray(a(i, 1))
  Next
 
  ' Do main
  ReDim b(1 To UBound(a), 1 To 2)
  i = 1
  j = i + 1
  Do
    s = vbNullString
    k = 0
    m = UBound(a(i, 2))
    If m > UBound(a(j, 2)) Then m = UBound(a(j, 2))
'    While a(i, 2)(k) = a(j, 2)(k)
'      s = s & a(i, 2)(k) & " "
'      k = k + 1
'    Wend
    Do
      If a(i, 2)(k) = a(j, 2)(k) Then
        s = s & a(i, 2)(k) & " "
        k = k + 1
      Else
        Exit Do
      End If
    Loop While k <= m
   
    If k > 0 Then
      If k <= UBound(a(i, 2)) Then
        s1 = ""
        For n = k + 1 To UBound(a(i, 2))
          s1 = s1 & a(i, 2)(n) & " "
        Next
        s1 = RTrim$(s1)
        s2 = ""
        For n = k + 1 To UBound(a(j, 2))
          s2 = s2 & a(j, 2)(n) & " "
        Next
        s2 = RTrim$(s2)
        If Len(s1) > 0 And s1 = s2 Then
          If j = i + 1 Then b(i, 1) = s & s1 '
          b(j, 1) = b(i, 1)
          b(i, 2) = a(i, 2)(k)
          b(j, 2) = a(j, 2)(k)
        Else
          b(i, 1) = RTrim$(s)
          b(j, 1) = b(i, 1)
          b(i, 2) = a(i, 2)(k) & s1
          b(j, 2) = a(j, 2)(k) & s2
        End If
        j = j + 1
        If j <= UBound(a) Then
          If Not a(j, 1) Like s & "*" Then
            i = j
            j = i + 1
          End If
        End If
      Else
        b(i, 1) = a(i, 1)
        If UBound(a(j, 2)) > UBound(a(i, 2)) Then
          b(j, 1) = s
          b(j, 2) = a(j, 2)(k) & s2
        Else
          b(j, 1) = a(j, 1)
        End If
        i = j
        j = i + 1
      End If
    Else
      b(i, 1) = a(i, 1)
      i = j
      j = i + 1
    End If
  Loop While j <= UBound(a)
 
  ' Create result
  Rng.Columns("C:D").Value = b()
 
  ' Sort Rng by UID
  With Rng
    .Sort .Cells(1, "A"), xlAscending, Header:=xlNo
  End With
 
  ' Enable screen updating
  Application.ScreenUpdating = True
 
End Sub
 
Function TxtToArray(Txt) As Variant
  Dim a, i As Long, j As Long, s As String
  Dim RegEx As Object
  If RegEx Is Nothing Then
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
    RegEx.Pattern = "[.,!?:;_\-]"
  End If
  s = RegEx.Replace(Txt, " ")
  If s Like "*(* *)*" Then
    i = InStr(s, "(")
    While i > 0
      j = InStr(i + 1, s, ")")
      If j > 1 Then
        s = Mid$(s, 1, i) & Replace(Mid$(s, i + 1, j - i - 1), " ", "") & Mid$(s, j)
        i = InStr(j + 1, s, "(")
      Else
        i = 0
      End If
    Wend
  End If
  a = Split(s)
  j = 0
  For i = 0 To UBound(a)
    If Len(a(i)) > 0 Then
      a(j) = a(i)
      j = j + 1
    End If
  Next
  If j - 1 < UBound(a) Then ReDim Preserve a(0 To j - 1)
  TxtToArray = a
End Function

leeandoona · Feb 27, 2019

ZVI said:

Code was developed for the posted data structure. And it works with it - try using the posted data.
There is no limitation in amount of data rows for the code.
The below is a bit enhanced version for some other data structures.
If it does not work then you may send me actual (not sensitive) data for testing other structures - just PM me to get my email.

Rich (BB code):

Option Explicit
Option Compare Text
 
Sub Main()
 
  Dim a(), b()
  Dim i As Long, j As Long, k As Long, n As Long, m As Long
  Dim Rng As Range
  Dim s As String, s1 As String, s2 As String
 
  ' Set data range A:D
  With ActiveSheet.UsedRange
    Set Rng = .Offset(1).Resize(.Rows.Count - 1).Columns("A:D")
  End With
 
  ' Normalize Dataset
  a() = Rng.Columns("B").Value
  For i = 1 To UBound(a)
    a(i, 1) = Join(TxtToArray(a(i, 1)))
  Next
 
  ' Disable screen updating
  Application.ScreenUpdating = False
 
  ' Sord Rng by Dataset
  With Rng
    .Columns("C").Value = a()
    .Sort .Cells(1, "C"), xlAscending, Header:=xlNo
  End With
 
  ' Convert normalized & sorted Dataset to array
  a() = Rng.Columns("C:D").Value
  For i = 1 To UBound(a)
    a(i, 2) = TxtToArray(a(i, 1))
  Next
 
  ' Do main
  ReDim b(1 To UBound(a), 1 To 2)
  i = 1
  j = i + 1
  Do
    s = vbNullString
    k = 0
    m = UBound(a(i, 2))
    If m > UBound(a(j, 2)) Then m = UBound(a(j, 2))
'    While a(i, 2)(k) = a(j, 2)(k)
'      s = s & a(i, 2)(k) & " "
'      k = k + 1
'    Wend
    Do
      If a(i, 2)(k) = a(j, 2)(k) Then
        s = s & a(i, 2)(k) & " "
        k = k + 1
      Else
        Exit Do
      End If
    Loop While k <= m
   
    If k > 0 Then
      If k <= UBound(a(i, 2)) Then
        s1 = ""
        For n = k + 1 To UBound(a(i, 2))
          s1 = s1 & a(i, 2)(n) & " "
        Next
        s1 = RTrim$(s1)
        s2 = ""
        For n = k + 1 To UBound(a(j, 2))
          s2 = s2 & a(j, 2)(n) & " "
        Next
        s2 = RTrim$(s2)
        If Len(s1) > 0 And s1 = s2 Then
          If j = i + 1 Then b(i, 1) = s & s1 '
          b(j, 1) = b(i, 1)
          b(i, 2) = a(i, 2)(k)
          b(j, 2) = a(j, 2)(k)
        Else
          b(i, 1) = RTrim$(s)
          b(j, 1) = b(i, 1)
          b(i, 2) = a(i, 2)(k) & s1
          b(j, 2) = a(j, 2)(k) & s2
        End If
        j = j + 1
        If j <= UBound(a) Then
          If Not a(j, 1) Like s & "*" Then
            i = j
            j = i + 1
          End If
        End If
      Else
        b(i, 1) = a(i, 1)
        If UBound(a(j, 2)) > UBound(a(i, 2)) Then
          b(j, 1) = s
          b(j, 2) = a(j, 2)(k) & s2
        Else
          b(j, 1) = a(j, 1)
        End If
        i = j
        j = i + 1
      End If
    Else
      b(i, 1) = a(i, 1)
      i = j
      j = i + 1
    End If
  Loop While j <= UBound(a)
 
  ' Create result
  Rng.Columns("C:D").Value = b()
 
  ' Sort Rng by UID
  With Rng
    .Sort .Cells(1, "A"), xlAscending, Header:=xlNo
  End With
 
  ' Enable screen updating
  Application.ScreenUpdating = True
 
End Sub
 
Function TxtToArray(Txt) As Variant
  Dim a, i As Long, j As Long, s As String
  Dim RegEx As Object
  If RegEx Is Nothing Then
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
    RegEx.Pattern = "[.,!?:;_\-]"
  End If
  s = RegEx.Replace(Txt, " ")
  If s Like "*(* *)*" Then
    i = InStr(s, "(")
    While i > 0
      j = InStr(i + 1, s, ")")
      If j > 1 Then
        s = Mid$(s, 1, i) & Replace(Mid$(s, i + 1, j - i - 1), " ", "") & Mid$(s, j)
        i = InStr(j + 1, s, "(")
      Else
        i = 0
      End If
    Wend
  End If
  a = Split(s)
  j = 0
  For i = 0 To UBound(a)
    If Len(a(i)) > 0 Then
      a(j) = a(i)
      j = j + 1
    End If
  Next
  If j - 1 < UBound(a) Then ReDim Preserve a(0 To j - 1)
  TxtToArray = a
End Function

That (almost) worked! Took a while to run. It seems to be struggling with items that contain more than one set of brackets in a cell. I'll PM you for email and send you the file to see if you can spot the problem. Very close to working though!

ZVI · Feb 27, 2019

Find my email in the sent PM

GR00007 · Feb 27, 2019

There have been so many amazing solutions proposed. Would a simpler approach be considered? Create a lookup tab consisting of the product and name to use, then do a simple VLOOKUP. This would entail maintenance as new products occur, but it may be more accurate in the long run.

Product	NameToUse
COLOUR CHANGING CRYSTAL BALL	COLOUR CHANGING CRYSTAL BALL
DEATHLY GRIM REAPER (128cm)	DEATHLY GRIM REAPER
DEATHLY GRIM REAPER (140cm)	DEATHLY GRIM REAPER
DEATHLY GRIM REAPER (158cm)	DEATHLY GRIM REAPER
DEATHLY GRIM REAPER (L)	DEATHLY GRIM REAPER
DEATHLY GRIM REAPER (M)	DEATHLY GRIM REAPER
DEATHLY GRIM REAPER (S)	DEATHLY GRIM REAPER
DEATHLY GRIM REAPER (XL)	DEATHLY GRIM REAPER
PETTICOAT BLACK - ONE SIZE	PETTICOAT - ONE SIZE
PETTICOAT RED - ONE SIZE	PETTICOAT - ONE SIZE
PETTICOAT WHITE - ONE SIZE	PETTICOAT - ONE SIZE
SANTAS LITTLE HELPER (116cm)	SANTAS LITTLE HELPER
SANTAS LITTLE HELPER (128cm)	SANTAS LITTLE HELPER
SANTAS LITTLE HELPER (140cm)	SANTAS LITTLE HELPER

Find Partial Duplicate values in a column

leeandoona

New Member

leeandoona

New Member

Excel Facts

leeandoona

New Member

leeandoona

New Member

ZVI

MrExcel MVP

leeandoona

New Member

leeandoona

New Member

ZVI

MrExcel MVP

leeandoona

New Member

ZVI

MrExcel MVP

GR00007

Board Regular

Similar threads

Forum statistics

Share this page

UID	Dataset 1	UID	Example Parent	Example Child
exmp/00005	SANTAS LITTLE HELPER (116cm)	exmp/00005	SANTAS LITTLE HELPER	(116cm)
exmp/00006	SANTAS LITTLE HELPER (128cm)	exmp/00006	SANTAS LITTLE HELPER	(128cm)
exmp/00007	SANTAS LITTLE HELPER (140cm)	exmp/00007	SANTAS LITTLE HELPER	(140cm)
exmp/00008	PETTICOAT WHITE - ONE SIZE	exmp/00008	PETTICOAT - ONE SIZE	WHITE
exmp/00009	PETTICOAT RED - ONE SIZE	exmp/00009	PETTICOAT - ONE SIZE	RED
exmp/00010	PETTICOAT BLACK - ONE SIZE	exmp/00010	PETTICOAT - ONE SIZE	BLACK
exmp/00011	DEATHLY GRIM REAPER (S)	exmp/00011	DEATHLY GRIM REAPER	(S)
exmp/00012	DEATHLY GRIM REAPER (M)	exmp/00012	DEATHLY GRIM REAPER	(M)
exmp/00013	DEATHLY GRIM REAPER (L)	exmp/00013	DEATHLY GRIM REAPER	(L)
exmp/00014	DEATHLY GRIM REAPER (XL)	exmp/00014	DEATHLY GRIM REAPER	(XL)
exmp/00015	COLOUR CHANGING CRYSTAL BALL	exmp/00015	COLOUR CHANGING CRYSTAL BALL
exmp/00016	DEATHLY GRIM REAPER (128cm)	exmp/00016	DEATHLY GRIM REAPER	(128cm)
exmp/00017	DEATHLY GRIM REAPER (140cm)	exmp/00017	DEATHLY GRIM REAPER	(140cm)
exmp/00018	DEATHLY GRIM REAPER (158cm)	exmp/00018	DEATHLY GRIM REAPER	(158cm)
exmp/00021	CAT (S)	exmp/00021	CAT	(S)
exmp/00022	CAT (M)	exmp/00022	CAT	(M)
exmp/00023	CAT (L)	exmp/00023	CAT	(L)
exmp/00025	HOLY MARY (116cm)	exmp/00025	HOLY MARY	(116cm)
exmp/00026	HOLY MARY (128cm)	exmp/00026	HOLY MARY	(128cm)
exmp/00027	HOLY MARY (140cm)	exmp/00027	HOLY MARY	(140cm)

Find Partial Duplicate values in a column

New Member

New Member

Excel Facts

New Member

New Member

MrExcel MVP

New Member

New Member

MrExcel MVP

New Member

MrExcel MVP

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock