HELP --- Macro For Related Items/Values

joi3288

New Member
Joined
Mar 14, 2011
Messages
11
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.
 

Some videos you may like

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this, for data in column "A & B" , Starting row 2.
Results start "E2".
Code:
[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

New Member
Joined
Mar 14, 2011
Messages
11
wow!! perfect. thank you so much. that lightens my task...works perfectly!
 

Watch MrExcel Video

Forum statistics

Threads
1,108,491
Messages
5,523,255
Members
409,506
Latest member
reneekeane

This Week's Hot Topics

Top