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:

	A	B	C	D	E	F	G
1	Size	Size	Color	Color	Color	Shape	Shape
2	1	3
3	6	8	Red	Blue
4	5	6	Red	Blue	White	Square	Circle

<tbody>
</tbody>

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:

	A	B	C
1	1
2	1.5
3	2
4	2.5
5	3
6	6	Red
7	6.5	Red
8	7	Red
9	7.5	Red
10	8	Red
11	6	Blue
12	6.5	Blue
13	7	Blue
14	7.5	Blue
15	8	Blue
16	5	Red	Square
17	5.5	Red	Square
18	6	Red	Square
19	5	Red	Circle
20	5.5	Red	Circle
21	6	Red	Circle
22	5	Blue	Square
23	5.5	Blue	Square
24	6	Blue	Square
26	5	Blue	Circle
27	5.5	Blue	Circle
28	6	Blue	Circle
29	5	White	Square
30	5.5	White	Square
31	6	White	Square
32	5	White	Circle
33	5.5	White	Circle
34	6	White	Circle

<tbody>
</tbody>

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