HELP --- Macro For Related Items/Values

[joi3288]

Hi,

I have these columns with their respective values:

Category | ProductID
Apparel | UA-101
Apparel | UA-102
Apparel | LA-101
Apparel | LA-102
Sports | Ten-101
Sports | Ten-102
Sports | Gol-101
Baby | Toy-1
Baby | Toy-2

since UA-101, UA-102, LA-101, LA-102 fall on the same category which is Apparel, all of these relates to each other. The same with other products under Sports, Baby, etc.

I want to create a new columns, say on Column E and F the following:
Column E | Column F
UA-101 | UA-101
UA-101 | UA-102
UA-101 | LA-101
UA-101 | LA-102
UA-102 | UA-101
UA-102 | UA-102
UA-102 | LA-101
UA-102 | LA-102
LA-101 | UA-101
LA-101 | UA-102
LA-101 | LA-101
LA-101 | LA-102
LA-102 | UA-101
LA-102 | UA-102
LA-102 | LA-101
LA-102 | LA-102

and so on. I hope I made myself clear with the above given data. Please help me solve this thing. It's prone to error doing the copy-and-paste. Thanks much.

 

[MickG]

Try this, for data in column "A & B" , Starting row 2.
Results start "E2".

[COLOR=navy]Sub[/COLOR] MG14Mar03
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Txt [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Dim[/COLOR] oRng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Rw [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] fRw [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & rows.Count).End(xlUp))
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        [COLOR=navy]If[/COLOR] Dn.row = Rng(1).row [COLOR=navy]Then[/COLOR]
            Txt = Txt & Dn.Address & ":"
        [COLOR=navy]ElseIf[/COLOR] Dn <> Dn.Offset(1) And Not Dn.Address = Rng(Rng.Count).Address [COLOR=navy]Then[/COLOR]
            Txt = Txt & Dn.Address & "," & Dn.Offset(1).Address & ":"
        [COLOR=navy]ElseIf[/COLOR] Dn.Address = Rng(Rng.Count).Address [COLOR=navy]Then[/COLOR]
             Txt = Txt & Dn.Address
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
 
 [COLOR=navy]Set[/COLOR] Rng = Range(Txt)
ReDim Ray(1 To rows.Count, 1 To 2)
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] oRng [COLOR=navy]In[/COLOR] Rng.Areas
       [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] fRw [COLOR=navy]In[/COLOR] oRng
            [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Rw [COLOR=navy]In[/COLOR] oRng
                c = c + 1
                Ray(c, 1) = fRw.Offset(, 1)
                Ray(c, 2) = Rw.Offset(, 1)
             [COLOR=navy]Next[/COLOR] Rw
        [COLOR=navy]Next[/COLOR] fRw
    [COLOR=navy]Next[/COLOR] oRng
Range("E2").Resize(c, 2) = Ray
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[joi3288]

wow!! perfect. thank you so much. that lightens my task...works perfectly!