Expand combinations into separate lines

[alfordtp]

[TABLE="width: 128"]
<tbody>[TR]
[TD="class: xl63, width: 64"]a[/TD]
[TD="class: xl63, width: 64"](e,f)[/TD]
[/TR]
[TR]
[TD="class: xl63"]a[/TD]
[TD="class: xl63"](g,h)[/TD]
[/TR]
[TR]
[TD="class: xl63"]b[/TD]
[TD="class: xl63"](x,y)[/TD]
[/TR]
[TR]
[TD="class: xl63"]c[/TD]
[TD="class: xl63"](x,y,z)[/TD]
[/TR]
[TR]
[TD="class: xl63"]c[/TD]
[TD="class: xl63"](j,k,l)[/TD]
[/TR]
[TR]
[TD="class: xl63"]d[/TD]
[TD="class: xl63"](m,n)[/TD]
[/TR]
</tbody>[/TABLE]

From the table above:
"a" can be matched with "e" or "f" or "g" or "h"
"b" can be matched with "x" or "y"
"c" can be matched with "x" or "y" or "z" or "j" or "k" or "l"
"d" can be matched with "m" or "n"

I need a macro that will expand out the options in the 2nd column into separate lines for each of the options. So instead of 6 lines, I need the output to be in 14 lines

What would be the easiest method for doing this?

 

[Mohammad Basem]

Hi alfordtp,

Try this

[FONT=Consolas][SIZE=2][COLOR=Navy]Sub Expand()
 
   Const clFirstRow As Long = 1                 [COLOR=Green]' 1st row of the table[/COLOR]
   Const ciFirstCol As Integer = 1              [COLOR=Green]' 1st column of the table[/COLOR]
   Const ciRefCol As Integer = ciFirstCol + 1   [COLOR=Green]' Reference column[/COLOR]
 
   Dim vArr As Variant  [COLOR=Green]' References array[/COLOR]
   Dim bRef As Byte     [COLOR=Green]' Number of references[/COLOR]
   Dim lRow As Long     [COLOR=Green]' Rows counter[/COLOR]
 
   Application.ScreenUpdating = False
   lRow = clFirstRow
   Do
      vArr = Split(Replace(Replace(Cells(lRow, ciRefCol).Value, "(", ""), ")", ""), ",")
      If UBound(vArr) < 0 Then Exit Do    [COLOR=Green]' Table end[/COLOR]
      bRef = 0
      Do While bRef <= UBound(vArr)
         With Range(Cells(lRow + bRef, ciFirstCol), Cells(lRow + bRef, ciRefCol))
            .Cells(1, 2) = vArr(bRef)     [COLOR=Green]' Offset[/COLOR]
            If bRef < UBound(vArr) Then
               .Copy
               .Insert xlShiftDown, True
            End If
         End With
         bRef = bRef + 1   [COLOR=Green]' Next reference[/COLOR]
      Loop
      lRow = lRow + bRef   [COLOR=Green]' Next group[/COLOR]
   Loop
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
 
End Sub[/COLOR][/SIZE][/FONT]

 

[alfordtp]

I can work with this to make it work. Thanks for your help!

 

[Mohammad Basem]

Hi alfordtp,

I can work with this to make it work…

Isn’t it working?

 

[alfordtp]

My example was something similar to what i was working on. I was able to modify the code to fit my data. Thanks again.

 

[Mohammad Basem]

Al-hamdullah, glad you found the solution!