Count duplicates in in A, then duplicates in B in that range, then work with data in B

[zookeepertx]

A	B	I	Z	AA	AB	AC
Once	fine	Once
Same	Double	Twice
Same	Double	Same
Different	New	Third
Fourth	Match	Different
Fourth	Match	Fourth
Fourth	Normal	Five
Fourth	Opposite	Sixth
Help	Sign	Apple
Help	Street	Help

<tbody>
</tbody>

A	B	I	Z	AA	AB	AC
Once	fine	Once	fine
		Twice
Same	Double	Same	Double
		Third
Different	New	Different	New
Fourth	Match	Fourth	Match	Normal	Opposite
		Five
		Sixth
		Apple
Help	Sign	Help	Sign	Street

<tbody>
</tbody>

I've been working on this for just about ever and am SICK of looking at it! Please help!

I need to find the data from column I in column A and - in the simplest case - return the data in column B into column Z.

* If there's no match in A for I, move all of columns A:B down - (ultimately, to where there IS a match in A for I).

* If there's 1 match in A for I, return data from B into column Z.
-If the row # in A isn't "level with" the row # it's matched with in I
~Move all of columns A:B down to where they are "level with" the row in I that A is matched with.

* If there are 2 matches in A for I, then:
-If B on the first row = B on the second row, return data from the first row where A matched, into Z.
-Delete A:B of the second matched A
-Move all of columns A:B down to where they are "level with" the row in I that A is matched with.
-If B on the second row <> B on the first row, return the first B into Z and the second B into AA.
-Delete A:B of the second matched A
-Move all of columns A:B down to where they are "level with" the row in I that A is matched with.

*If there are more than 2 matches in A for I, then:
-Return data from the first row where A matched into Z.
-If B on the subsequent rows = B on any of the above rows, then ignore the data in THAT B only.
-If B on the first row <> B on any of the above rows, return each subsequent non-duplicated B into the columns after Z.
-Delete A:B of all of the matched A's after the first one.
-Move all of columns A:B down to where they are "level with" the row in I that A is matched with.

MAN, this is hard to explain with words!! I hope I've made some sense!

The tables above show a small version of the original and then a small version of the desired result.

I hope someone can figure this out for me, because I'm getting nowhere fast!

Thanks

Jenny

 

[RSpin]

Ok, I hope I understood this correctly. Here is the vba code I came up with:

Sub craziness()


Dim ABC() As Variant
Dim XYZ() As Variant
Dim Ran As Range
Dim BB As Integer
Dim CC As Integer
Dim DD As Integer
Dim EE As Integer


Set Ran = Range("A1:AC10")
ReDim ABC(1 To 10, 1 To 29)
ReDim XYZ(1 To 10, 1 To 29)
ABC = Ran


For BB = 1 To 10
    XYZ(BB, 9) = ABC(BB, 9)
    DD = 0
    For CC = 1 To 10
        If XYZ(BB, 9) = ABC(CC, 1) Then
            DD = DD + 1
            If DD = 1 Then
                XYZ(BB, 1) = ABC(CC, 1)
                XYZ(BB, 2) = ABC(CC, 2)
            End If
            For EE = 1 To DD
                If XYZ(BB, 25 + EE) = ABC(CC, 2) Then
                    Exit For
                Else
                    If XYZ(BB, 25 + EE) = Empty Then
                        XYZ(BB, 25 + EE) = ABC(CC, 2)
                        Exit For
                    End If
                End If
            Next EE
        End If
    Next CC
Next BB


For BB = 1 To 10
    ABC(BB, 1) = XYZ(BB, 1)
    ABC(BB, 2) = XYZ(BB, 2)
    ABC(BB, 9) = XYZ(BB, 9)
    ABC(BB, 26) = XYZ(BB, 26)
    ABC(BB, 27) = XYZ(BB, 27)
    ABC(BB, 28) = XYZ(BB, 28)
    ABC(BB, 29) = XYZ(BB, 29)
Next BB
Ran = ABC


End Sub

If the data you are using this for, extends beyond the 10 rows in your example, or if there is the possiblilty of more than 4 matches that will go in columns Z through AC, then some of the code will need to be edited.

I hope this helps.

 

[MickG]

Another option :-

[COLOR="Navy"]Sub[/COLOR] MG15Dec51
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] k           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Value).Add (Dn.Offset(, 1).Value), Dn
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
   ReDim ray(1 To Rng.Count, 1 To 2)
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Offset(, 8)
      c = 0
      
      [COLOR="Navy"]If[/COLOR] Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(Dn.Value)
            c = c + 1
            Dn.Offset(, 16 + c) = p
            [COLOR="Navy"]If[/COLOR] c = 1 [COLOR="Navy"]Then[/COLOR]
                ray(Dn.Row, 1) = Dic(Dn.Value).Item(p)
                ray(Dn.Row, 2) = Dic(Dn.Value).Item(p).Offset(, 1)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] p
      [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
Range("A1").Resize(Rng.Count, 2).Value = ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[zookeepertx]

Hi RSpin!

I finally got a chance to get back here!

Your code works great after I made a few minor adjustments! However, there is definitely the possibility of more than 4 matches, so it does need to be able to use as many columns as required. There's no telling how many there may be; there probably won't be more than 4-5, but you never know. Can the "results range" be dynamic?

Thank you!

Jenny

 

[zookeepertx]

Hello again MickG!

Your coding works 99% perfectly - I just had to make a couple of small adjustments on references - and I can definitely work with it as is. The only thing (a small thing) is that somehow, the data in A:B ends up 1 row below the data in the other columns. For example, if the match for I2 is originally in A2, after the macro, A2:B2 end up in A3:B3. Not sure how or when that happens, because I can't decipher the most important part of the coding, LOL!

If it's a pain to change that, my end-user can absolutely deal with it.

Thank you very much! I'm over here doing a happy dance

Jenny

 

[RSpin]

... there is definitely the possibility of more than 4 matches, so it does need to be able to use as many columns as required. There's no telling how many there may be; there probably won't be more than 4-5, but you never know. Can the "results range" be dynamic?

My apologies. I did not even consider making the range dynamic. I rewrote some of the code allowing for a fully dynamic number of matches, and rows. Although, if you don't want the number of rows to be dynamic, then you can simply replace the "Lrow = find_last_row_code" with "Lrow = 10" (or however many rows you want).

 Sub craziness()

Dim ABC() As Variant
Dim XYZ() As Variant
Dim Ran As Range
Dim BB As Integer
Dim CC As Integer
Dim DD As Integer
Dim EE As Integer
Dim FF As Integer
Dim Lrow As Long
Dim ColumnString As String


Lrow = ActiveSheet.UsedRange.Rows.Count
Set Ran = Range("A1:Y" & Lrow)
ReDim ABC(1 To Lrow, 1 To 25)
ReDim XYZ(1 To Lrow, 1 To 25)
ABC = Ran
FF = 0


For BB = 1 To Lrow
    XYZ(BB, 9) = ABC(BB, 9)
    DD = 0
    For CC = 1 To Lrow
        If XYZ(BB, 9) = ABC(CC, 1) Then
            DD = DD + 1
            If DD = 1 Then
                XYZ(BB, 1) = ABC(CC, 1)
                XYZ(BB, 2) = ABC(CC, 2)
            End If
            If DD > FF Then
                FF = DD
                ReDim Preserve XYZ(1 To Lrow, 1 To (25 + FF))
                ReDim Preserve ABC(1 To Lrow, 1 To (25 + FF))
            End If
            For EE = 1 To DD
                If XYZ(BB, 25 + EE) = ABC(CC, 2) Then
                    Exit For
                Else
                    If XYZ(BB, 25 + EE) = Empty Then
                        XYZ(BB, 25 + EE) = ABC(CC, 2)
                        Exit For
                    End If
                End If
            Next EE
        End If
    Next CC
Next BB


For BB = 1 To Lrow
    ABC(BB, 1) = XYZ(BB, 1)
    ABC(BB, 2) = XYZ(BB, 2)
    ABC(BB, 9) = XYZ(BB, 9)
    If FF > 0 Then
        For CC = 26 To UBound(ABC, 2)
            ABC(BB, CC) = XYZ(BB, CC)
        Next CC
    End If
Next BB


' Find Last used column letter
If UBound(XYZ, 2) > 26 Then
    BB = Int(UBound(XYZ, 2) / 26)
    CC = UBound(XYZ, 2) - (BB * 26)
    ColumnString = Chr(BB + 64) & Chr(CC + 64)
Else
    ColumnString = Chr(UBound(XYZ, 2) + 64)
End If
Set Ran = Range("A1:" & ColumnString & Lrow)
Ran = ABC




End Sub

Your code works great after I made a few minor adjustments!

Unfortunately, you will probably have to make those adustments again, as I modified the code I sent you the first time. Let me know if this works out for you.

 

[MickG]

It could be because your actual data starts in "A2",and not in "A1", is that the case ????