Searching for Duplicates

FrankieBue · Jun 23rd 2015

Hi Friends ,
As shown for example in Col N O P... as in the following image…

[Blocked Image: http://i62.tinypic.com/24641oi.jpg]

I'm searching…

For Each Row having Same Values in Columns A B C D …
If there are some duplicates…

For Columns F I L …
-> Finding Duplicates
-> Ordering from the Smallest to the Biggest (They can't be also ordered)
-> Concatenating of them (also not ordered)

I attach a sample file for greater understanding.

Every suggestion and every form of help is appreciated;
preferably in the form of Excel formula (also vba),
such as to understand the process of what I research.

Many thanks in advance to everyone who will come to my aid.
Frankie.

Anonymous · Jun 23rd 2015

Re: Searching for Duplicates

The following macro seems to do what you ask. Check it and see.

Code

Sub CollectTerms()
    Dim c As Collection, i As Long, ib As Long, ie As Long, ii As Long, j As Long, _
        jj As Long, k As Long, s As String, t() As String, v As Variant, x As String
    v = Cells(1).CurrentRegion.Resize(, 4)
    ib = 2
    For i = 3 To UBound(v)
        For j = 4 To 1 Step -1
            If v(i, j) <> v(ib, j) Then
                ie = i - 1
                GoSub Handle
                ib = ie + 1
                i = i + 1
                Exit For
            End If
        Next j
    Next i
    ie = UBound(v)
    GoSub Handle
    Exit Sub
Handle:
    k = 13
    For j = 6 To 12 Step 3
        k = k + 1
        Set c = New Collection
        On Error Resume Next
        For ii = ib To ie
            c.Add Cells(ii, j).Text, Cells(ii, j).Text
        Next ii
        On Error GoTo 0
        ReDim t(1 To c.Count)
        For ii = 1 To c.Count
            t(ii) = c(ii)
        Next ii
        For ii = 1 To c.Count - 1
            For jj = ii + 1 To c.Count
                If t(ii) > t(jj) Then
                    x = t(ii)
                    t(ii) = t(jj)
                    t(jj) = x
                End If
            Next jj
        Next ii
        s = t(1)
        For ii = 2 To c.Count
            s = s & " " & t(ii)
        Next ii
        Range(Cells(ib, k), Cells(ie, k)) = s
    Next j
    Return
End Sub

Display More

FrankieBue · Jun 23rd 2015

Re: Searching for Duplicates

Hello Derk,

with great pleasure I thank You for having solved in part what I want.

One last thing is missing:

I try to be concatenated only duplicate values... as highlighted in red in the N O P columns.
Those values that occur only once should not appear in the result of the concatenation.

[Blocked Image: http://i62.tinypic.com/156qna1.jpg]

As shown in columns Q R S, I think that the posted image will clarify even better the result I want.

I wait patiently for you.
forum.ozgrid.com/index.php?attachment/65808/

You are a BIG!
Many Thanks again.

Frank.

Anonymous · Jun 24th 2015

Re: Searching for Duplicates

I think I now understand what you would like. I am out of time today to make changes, but will do so tomorrow.

FrankieBue · Jun 24th 2015

Re: Searching for Duplicates

Quote from Derk;749634

I think I now understand what you would like. I am out of time today to make changes, but will do so tomorrow.

You are great.
Thanks for understanding what I want.

See You tomorrow Derk.

Many Thanks again.

Frank.

jindon · Jun 24th 2015

Re: Searching for Duplicates

Try the attached

Code

Sub test()
    Dim a, i As Long, ii As Long, iii As Long, txt As String, w, e, temp, AL As Object
    Set AL = CreateObject("System.Collections.ArrayList")
    With Cells(1).CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
                If Not .exists(txt) Then
                    ReDim w(1 To 3)
                    For ii = 1 To 3
                        Set w(ii) = CreateObject("System.Collections.ArrayList")
                    Next
                Else
                    w = .Item(txt)
                End If
                For ii = 1 To 3
                    w(ii).Add a(i, (ii + 1) * 3)
                Next
                .Item(txt) = w
            Next
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
                For ii = 1 To 3
                    .Item(txt)(ii).Sort
                    If .Item(txt)(ii).Count > 1 Then
                        For iii = 1 To .Item(txt)(ii).Count - 1
                            If .Item(txt)(ii)(iii - 1) = .Item(txt)(ii)(iii) Then
                                If Not AL.Contains(.Item(txt)(ii)(iii)) Then
                                    AL.Add .Item(txt)(ii)(iii)
                                End If
                            End If
                        Next
                        a(i, ii + 13) = Join(AL.ToArray): AL.Clear
                    End If
                Next
            Next
        End With
        .Value = a
    End With
End Sub

Display More

FrankieBue · Jun 24th 2015

Re: Searching for Duplicates

Hello guys,

I think we are close to the solution of what I want.

jindon thank You for Your time, thank You again also Derk.

As can be seen from the file that I enclose,

jindon, Your macro works... just that there are still errors how I wish to be populated and chained values for each row.

Guys there is an alternative to UBond ???

Let me explain:

For the search for values, can we use a for loop next...
where the values are taken as follows ?

- ) from the 2nd row
- ) to the last non-empty row... in reference to column A ?

... For i = 2 to last_format_row ... ?

Thanks so much to You for dedicated time to what I want.
I await Your solutions.

I apologize to attach the sample as follows:

https://www.dropbox.com/s/26jo…ear.To.Solution.xlsm?dl=0
http://wikisend.com/download/945512/Near.To.Solution.xlsm

Frank.

jindon · Jun 24th 2015

Re: Searching for Duplicates

OK you have duplicate group in separate block...

Code

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, iv As Long
    Dim txt As String, w, e, temp, SL As Object, x As Long, y As Long
    Set SL = CreateObject("System.Collections.SortedList")
    With Cells(1).CurrentRegion
        a = .Value: ReDim b(1 To UBound(a, 1), 1 To 3)
        For i = 2 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
            If (temp <> txt) + (i = UBound(a, 1)) Then
                temp = txt: If i = UBound(a, 1) Then y = i
                If i > 2 Then
                    For ii = 1 To 3
                        For Each e In Split(w(ii), Chr(2))
                            If e <> "" Then SL(e) = SL(e) + 1
                        Next
                        For iii = 0 To SL.Count - 1
                            If SL.GetByIndex(iii) > 1 Then
                                For iv = x To y
                                    b(iv - 1, ii) = Trim$(b(iv - 1, ii) & " " & SL.GetKey(iii))
                                Next
                            End If
                        Next
                        SL.Clear
                    Next
                End If
                ReDim w(1 To 3)
                For ii = 1 To 3
                    w(ii) = a(i, (ii + 1) * 3)
                Next
                x = i: y = i
            Else
                y = i
                For ii = 1 To 3
                    w(ii) = Join(Array(w(ii), a(i, (ii + 1) * 3)), Chr(2))
                Next
            End If
            DoEvents
        Next
        .Columns("n:p").Offset(1).Value = b
    End With
End Sub

Display More

FrankieBue · Jun 24th 2015

Solved: Searching for Duplicate group in separate block

Quote from jindon;749707

OK you have duplicate group in separate block...

Code

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, iv As Long
    Dim txt As String, w, e, temp, SL As Object, x As Long, y As Long
    Set SL = CreateObject("System.Collections.SortedList")
    With Cells(1).CurrentRegion
        a = .Value: ReDim b(1 To UBound(a, 1), 1 To 3)
        For i = 2 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
            If (temp <> txt) + (i = UBound(a, 1)) Then
                temp = txt: If i = UBound(a, 1) Then y = i
                If i > 2 Then
                    For ii = 1 To 3
                        For Each e In Split(w(ii), Chr(2))
                            If e <> "" Then SL(e) = SL(e) + 1
                        Next
                        For iii = 0 To SL.Count - 1
                            If SL.GetByIndex(iii) > 1 Then
                                For iv = x To y
                                    b(iv - 1, ii) = Trim$(b(iv - 1, ii) & " " & SL.GetKey(iii))
                                Next
                            End If
                        Next
                        SL.Clear
                    Next
                End If
                ReDim w(1 To 3)
                For ii = 1 To 3
                    w(ii) = a(i, (ii + 1) * 3)
                Next
                x = i: y = i
            Else
                y = i
                For ii = 1 To 3
                    w(ii) = Join(Array(w(ii), a(i, (ii + 1) * 3)), Chr(2))
                Next
            End If
            DoEvents
        Next
        .Columns("n:p").Offset(1).Value = b
    End With
End Sub

Display More

What a great thing You've solved to me jindon.
Great Great!!!
Really thanks!!!

Many thanks to You and to Derk.

Nice to have met You.
See You next time.

Really thank You again.

Frank.

jindon · Jun 24th 2015

Re: Searching for Duplicates

You are welcome and thanks for the feedback.

FrankieBue · Jun 24th 2015

Re: Searching for Duplicates

Guys,

I have one last question:

I'm sorry, but if I had no more values in F I L...

but it had the values to be concatenated in J M P...

as to show them chained in Ap Aq Ar ... how should I do ??

Many thanks again.
Sorry.

Frank.

Anonymous · Jun 24th 2015

Re: Searching for Duplicates

I see Jindon came through with his code. For the record, here is my revision. (I'' take a look at your latest question, later.

Code

Sub CollectTerms()
    Dim c As Collection, d As Collection, i As Long, ib As Long, ie As Long, ii As Long, j As Long, _
    jj As Long, k As Long, s As String, t() As String, v As Variant, x As String
    v = Cells(1).CurrentRegion.Resize(, 4)
    ib = 2
    For i = 3 To UBound(v)
        For j = 4 To 1 Step -1
            If v(i, j) <> v(ib, j) Then
                ie = i - 1
                GoSub Handle
                ib = ie + 1
                i = i + 1
                Exit For
            End If
        Next j
    Next i
    ie = UBound(v)
    GoSub Handle
    Exit Sub
Handle:
    k = 13
    For j = 6 To 12 Step 3
        k = k + 1
        Set c = New Collection
        Set d = New Collection
        On Error Resume Next
        For ii = ib To ie
            d.Add Cells(ii, j).Text, Cells(ii, j).Text
            If Err.Number <> 0 Then 'have dup
                c.Add Cells(ii, j).Text, Cells(ii, j).Text
            End If
            Err.Clear
        Next ii
        On Error GoTo 0
        If c.Count = 0 Then
            s = ""
        Else
            ReDim t(1 To c.Count)
            For ii = 1 To c.Count
                t(ii) = c(ii)
            Next ii
            For ii = 1 To c.Count - 1
                For jj = ii + 1 To c.Count
                    If t(ii) > t(jj) Then
                        x = t(ii)
                        t(ii) = t(jj)
                        t(jj) = x
                    End If
                Next jj
            Next ii
            s = t(1)
            For ii = 2 To c.Count
                s = s & " " & t(ii)
            Next ii
        End If
        Range(Cells(ib, k), Cells(ie, k)) = s
    Next j
    Return
End Sub

Display More

jindon · Jun 24th 2015

Re: Searching for Duplicates

Hi Derk,

FrankieBlue, change to this. (found a bug as well)
No need Screeupdating/Calculation set to false as it is doing everything within memory.

Code

Sub M_Concatena_Occorrenze_1X2()




    Dim a, b, i As Long, ii As Long, iii As Long, iv As Long
    Dim txt As String, w, e, temp, SL As Object, x As Long, y As Long
    Set SL = CreateObject("System.Collections.SortedList")
    With Cells(1).CurrentRegion
        a = .Resize(, 16).Value: ReDim b(1 To UBound(a, 1), 1 To 3)
        For i = 2 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
            If (temp <> txt) + (i = UBound(a, 1)) Then
                temp = txt
                If i = UBound(a, 1) Then
                    y = i
                    For ii = 1 To 3
                        w(ii) = Join(Array(w(ii), a(i, (ii - 1) * 3 + 10)), Chr(2))
                    Next
                End If
                If i > 2 Then
                    For ii = 1 To 3
                        For Each e In Split(w(ii), Chr(2))
                            If e <> "" Then SL(e) = SL(e) + 1
                        Next
                        For iii = 0 To SL.Count - 1
                            If SL.GetByIndex(iii) > 1 Then
                                For iv = x To y
                                    b(iv - 1, ii) = Trim$(b(iv - 1, ii) & " " & SL.GetKey(iii))
                                Next
                            End If
                        Next
                        SL.Clear
                    Next
                End If
                ReDim w(1 To 3)
                For ii = 1 To 3
                    w(ii) = a(i, (ii - 1) * 3 + 10)
                Next
                x = i: y = i
            Else
                y = i
                For ii = 1 To 3
                    w(ii) = Join(Array(w(ii), a(i, (ii - 1) * 3 + 10)), Chr(2))
                Next
            End If
        Next
        .Columns("ap:ar").Offset(1).Value = b
    End With
End Sub

Display More

FrankieBue · Jun 24th 2015

Re: Searching for Duplicates Solved

Thanks both Guys.

You were Great Great Great!!!

I don't know what to say!!!

I appreciate both of your cycles.

I preferred to jindon for speed.

I prefer regard to routine understanding the cycle of Derk.

Many thanks to both still!!!

I am speechless before your dedication and professionalism.

Thanks again.

I'm very very happy!!!!

See you soon.

Frank.

Searching for Duplicates

Participate now!

Share