VBA macro for combining values from different categories

[jjxl1]

I have data organized in Sheet1 in range A1:G4 with the first table below; row 1 is a header row. Columns A and B have the lower and upper bounds of a range of Sizes. C:E have Colors and F:G have Shapes

Consider the following data in Sheet1:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Size[/TD]
[TD]Size[/TD]
[TD]Color[/TD]
[TD]Color[/TD]
[TD]Color[/TD]
[TD]Shape[/TD]
[TD]Shape[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1[/TD]
[TD]3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]6[/TD]
[TD]8[/TD]
[TD]Red[/TD]
[TD]Blue[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]Red[/TD]
[TD]Blue[/TD]
[TD]White[/TD]
[TD]Square[/TD]
[TD]Circle[/TD]
[/TR]
</tbody>[/TABLE]

I am trying to create a macro that will populate Rows in Sheet2 with 1 Size, 1 Color and 1 Shape (where applicable). Note that there will always be a Size but not always Color and Shape. Also, if it helps, there will only be Shape if there is Color. So either (Size Color Shape), (Size Color) or just (Size).

I am trying to get an output in Sheet 2 that looks like what I have below. Since the Size indicate the lower and upper range of Size, I need to fill in between those sizes in increments of 0.5.

Output I am looking for:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]1[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1.5[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]2[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]2.5[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]3[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]6[/TD]
[TD]Red[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]6.5[/TD]
[TD]Red[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]7[/TD]
[TD]Red[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]7.5[/TD]
[TD]Red[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]8[/TD]
[TD]Red[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]6[/TD]
[TD]Blue[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD]6.5[/TD]
[TD]Blue[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]7[/TD]
[TD]Blue[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]14[/TD]
[TD]7.5[/TD]
[TD]Blue[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]15[/TD]
[TD]8[/TD]
[TD]Blue[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]16[/TD]
[TD]5[/TD]
[TD]Red[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]17[/TD]
[TD]5.5[/TD]
[TD]Red[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]18[/TD]
[TD]6[/TD]
[TD]Red[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]19[/TD]
[TD]5[/TD]
[TD]Red[/TD]
[TD]Circle[/TD]
[/TR]
[TR]
[TD]20[/TD]
[TD]5.5[/TD]
[TD]Red[/TD]
[TD]Circle[/TD]
[/TR]
[TR]
[TD]21[/TD]
[TD]6[/TD]
[TD]Red[/TD]
[TD]Circle[/TD]
[/TR]
[TR]
[TD]22[/TD]
[TD]5[/TD]
[TD]Blue[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]5.5[/TD]
[TD]Blue[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]24[/TD]
[TD]6[/TD]
[TD]Blue[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]26[/TD]
[TD]5[/TD]
[TD]Blue[/TD]
[TD]Circle[/TD]
[/TR]
[TR]
[TD]27[/TD]
[TD]5.5[/TD]
[TD]Blue[/TD]
[TD]Circle[/TD]
[/TR]
[TR]
[TD]28[/TD]
[TD]6[/TD]
[TD]Blue[/TD]
[TD]Circle[/TD]
[/TR]
[TR]
[TD]29[/TD]
[TD]5[/TD]
[TD]White[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]30[/TD]
[TD]5.5[/TD]
[TD]White[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]31[/TD]
[TD]6[/TD]
[TD]White[/TD]
[TD]Square[/TD]
[/TR]
[TR]
[TD]32[/TD]
[TD]5[/TD]
[TD]White[/TD]
[TD]Circle[/TD]
[/TR]
[TR]
[TD]33[/TD]
[TD]5.5[/TD]
[TD]White[/TD]
[TD]Circle[/TD]
[/TR]
[TR]
[TD]34[/TD]
[TD]6[/TD]
[TD]White[/TD]
[TD]Circle[/TD]
[/TR]
</tbody>[/TABLE]

In Sheet 1, I have hundreds of rows that have various combinations of Size, Color and Shape and am hoping to find a VBA macro that can help do this quickly. Thank you so much in advance!

 

[ravishankar]

try the following macro. it has worked for me with your data.

Sub arrange_JJXL1()
b = 2
Sheets("sheet2").UsedRange.ClearContents
x = Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For a = 3 To x
e = WorksheetFunction.CountA(Sheets("sheet1").Range("D" & a & ":F" & a))
g = WorksheetFunction.CountA(Sheets("sheet1").Range("g" & a & ":H" & a))

For f = 0 To e
For h = 0 To g
For d = Sheets("sheet1").Cells(a, 2) To Sheets("sheet1").Cells(a, 3) Step 0.5

Sheets("sheet2").Cells(b, 1) = b - 1
Sheets("sheet2").Cells(b, 2) = d
If f <> 0 Then
Sheets("sheet2").Cells(b, 3) = Sheets("sheet1").Cells(a, f + 3)
Sheets("sheet2").Cells(b, 4) = Sheets("sheet1").Cells(a, h + 6)
End If
b = b + 1
Next d
Next h
Next f
Next a
MsgBox "complete"
End Sub

ravishankar