Grouping Like Column in Like Row

[kloocat1]

Okay so I have quite the conundrum. I'm pulling hierarchical data out of a data system. I'm utilizing Monarch 11 in order to strip out the necessary data that i need. An example of what I'm left with is below.

PROFILE NAME	Option1	Option2	Option3	Option4	Option5
BASIC	ACE	ACE	SCE	ZBE	ZBE
BASIC	ZBE	ZBE	ZZE	ZZF	ZZF
BASIC	ZZZ
INTERMEDIATE	BBE	CCE
ADVANCED	ACE	BCV	BCV	CDE	FGE
ADVANCED	REY	REY	ZZE	ZZE	ZZZ

<tbody>
</tbody>

Basically it's a profile name that can have various different options with various sub-options. I didn't need the sub-options for what I'm doing with the data so I didn't strip out the sub-options. The number of options that are available to the profile names vary. Since I didn't strip out the sub-options, I'm left with duplicated options (essentially, each duplicated option you see just means that there was more than one sub-option which is why it stripped out the duplicate option). I basically want to copy the data from each like row (profile name) into just one unique profile name row. I then need to have each option to only show up once in each row (taking out the duplicate options within the row). I have over 1400 rows of data that show duplicates on both the rows and the data (as explained above). I need this all consolidated as such so I can throw it into an Access database for easy viewing of what options are available to each profile name. Any assistance with this issue is greatly appreciated!



V/R,

Chad

 

[MickG]

Try this:-
Results start "H1"

[COLOR="Navy"]Sub[/COLOR] MG24Aug39
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, Ray [COLOR="Navy"]As[/COLOR] Variant, k [COLOR="Navy"]As[/COLOR] Variant, G [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] a [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 Ray = Range("A1").CurrentRegion
   [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR="Navy"]For[/COLOR] Rw = 1 To UBound(Ray, 1)
       [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(Rw, 1)) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Ray(Rw, 1)) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
                Dic(Ray(Rw, 1))(Ray(Rw, Ac)) = Empty
        [COLOR="Navy"]Next[/COLOR] Ac
  [COLOR="Navy"]Next[/COLOR] Rw
   
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
    c = c + 1: a = 0
    Cells(c, "H").Value = k
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic(k)
        a = a + 1
        Cells(1, a + 8).Value = "Option " & a
        Cells(c, a + 8).Value = G
    [COLOR="Navy"]Next[/COLOR] G
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[kloocat1]

I can't thank you enough! It seems to work. I actually have 9 Columns (including the profile name column), how do I change the code to include the extra columns? Thanks again for the help!

 

[MickG]

Try this for results on sheet 2 starting "A1"

[COLOR="Navy"]Sub[/COLOR] MG24Aug50
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, Ray [COLOR="Navy"]As[/COLOR] Variant, k [COLOR="Navy"]As[/COLOR] Variant, G [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] a [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 Ray = Range("A1").CurrentRegion
   [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR="Navy"]For[/COLOR] Rw = 1 To UBound(Ray, 1)
       [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
            [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Ray(Rw, 1)) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Ray(Rw, 1)) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
                Dic(Ray(Rw, 1))(Ray(Rw, Ac)) = Empty
        [COLOR="Navy"]Next[/COLOR] Ac
  [COLOR="Navy"]Next[/COLOR] Rw
   
ReDim nray(1 To UBound(Ray, 1), 1 To UBound(Ray, 1) * UBound(Ray, 2))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.keys
    c = c + 1: a = 1
    nray(c, 1) = k
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic(k)
        a = a + 1
        nray(1, a) = "Option " & a
        nray(c, a) = G
       oMax = Application.Max(oMax, a)
    [COLOR="Navy"]Next[/COLOR] G
[COLOR="Navy"]Next[/COLOR] k
 [COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, oMax)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
 [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[kloocat1]

That worked perfectly! I really appreciate! I tried making sense of the coding to see if I could change the selected area, but it's completely foreign to me.

V/R,
Chad

 

[MickG]

You're welcome