Transposing data with Loop

[Luin29]

Hello all,

I am hoping for some assistance with a code I have been working on. The purpose of the code is to transpose sets of data from a column that are separated by blank rows into a summary table in the same workbook. An example of what I am trying to accomplish is provided below:

Store	Item	Number Sold
A1	Baseballs	20
A1	Bats	5
A1	Shorts	35
A1	Volleyballs	12
A1	Tennis Rackets	15
A1	Swim Trunks	10
B16	Baseballs	22
B16	Bats	8
B16	Shorts	45
B16	Volleyballs	6
B16	Tennis Rackets	7
B16	Swim Trunks	5
B16	Gloves	2
Into this:
Store	Baseballs	Bats	Shorts	Volleyballs	Tennis Rackets	Swim Trunks	Gloves
A1	20	5	35	12	15	10	--
B16	22	8	45	6	7	5	2

<tbody>
</tbody>

Here is what I have so far:

Dim j, jtotalrows As Integer
Dim stRange As String
 Worksheets("Sheet1").Activate
jtotalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
Do While j <= jtotalrows
    j = j + 1
    stRange = "A" & j
    stRange2 = "A" & j + 1
    If Range(stRange).Text <> Range(stRange2).Text Then
        Range(Range("A" & j).Offset(1, 6), Range("A" & j).End(xlDown).Offset(, 6)).Copy
        jtotalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
        Worksheets("Summary Table").Range("A" & j).Offset(1, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        j = j + 1
        Worksheets("Sheet1").Activate
    End If
Loop

I would appreciate any help anyone can provide.

​Thanks

 

[Oeldere]

without VBA,

with a pivot table.

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
12	Store	Item	Number Sold
13	A1	Baseballs	20			Som van Number Sold	Kolomlabels
14	A1	Bats	5			Rijlabels	Baseballs	Bats	Gloves	Shorts	Swim Trunks	Tennis Rackets	Volleyballs	Eindtotaal
15	A1	Shorts	35			A1	20	5		35	10	15	12	97
16	A1	Volleyballs	12			B16	22	8	2	45	5	7	6	95
17	A1	Tennis Rackets	15			Eindtotaal	42	13	2	80	15	22	18	192
18	A1	Swim Trunks	10
19
20	B16	Baseballs	22
21	B16	Bats	8
22	B16	Shorts	45
23	B16	Volleyballs	6
24	B16	Tennis Rackets	7
25	B16	Swim Trunks	5
26	B16	Gloves	2
27
Blad25

 

[Luin29]

Thanks for the suggestion of a pivot table but I will be using text that needs to be present. Below is an actual example of data that will be summarized:

1A	09/03/15	Benzene	ND<0.5
1A	09/03/15	1,1-Dichloroethane	3.3
1A	09/03/15	1,2-Dichloroethane	ND<0.5
1A	09/03/15	Trichloroethene	1.1
1A	09/03/15	Vinyl Chloride	ND<0.5
3C	09/06/15	1,1-Dichloroethane	5.9
3C	09/06/15	1,2-Dichloroethane	ND<0.5
3C	09/06/15	Trichloroethene	3.5
3C	09/06/15	Vinyl Chloride	ND<0.5

<tbody>
</tbody><colgroup><col><col><col><col></colgroup>

Into this:

		Benzene	1,1-Dichloroethane	1,2-Dichloroethane	Trichloroethene	Vinyl Chloride
1A	09/03/15	ND<0.5	3.3	ND<0.5	1.1	ND<0.5
3C	09/06/15	--	5.9	ND<0.5	3.5	ND<0.5

<tbody>
</tbody><colgroup><col><col><col span="5"></colgroup>

Thanks.

 

[Oeldere]

Maybe like this.

Book1
	A	B	C	D	E	F	G	H
10	help	number	date	name	sub name
11	1A42072Benzene	1A	9-3-2015	Benzene	ND<0.5
12	1A420721,1-Dichloroethane	1A	9-3-2015	1,1-Dichloroethane	3.3
13	1A420721,2-Dichloroethane	1A	9-3-2015	1,2-Dichloroethane	ND<0.5
14	1A42072Trichloroethene	1A	9-3-2015	Trichloroethene	1.1
15	1A42072Vinyl Chloride	1A	9-3-2015	Vinyl Chloride	ND<0.5
16
17	3C421641,1-Dichloroethane	3C	9-6-2015	1,1-Dichloroethane	5.9
18	3C421641,2-Dichloroethane	3C	9-6-2015	1,2-Dichloroethane	ND<0.5
19	3C42164Trichloroethene	3C	9-6-2015	Trichloroethene	3.5
20	3C42164Vinyl Chloride	3C	9-6-2015	Vinyl Chloride	ND<0.5
21
22		Into this:
23
24				Benzene	1,1-Dichloroethane	1,2-Dichloroethane	Trichloroethene	Vinyl Chloride
25		1A	9-3-2015	ND<0.5	3.3	ND<0.5	1.1	ND<0.5
26		3C	9-6-2015	--	5.9	ND<0.5	3.5	ND<0.5
27
Blad25

Cell Formulas
Range	Formula
A11	=B11&C11&D11
D25	=IFERROR(VLOOKUP($B25&$C25&D$24,$A$10:$E$20,5,0),"--")
E25	=IFERROR(VLOOKUP($B25&$C25&E$24,$A$10:$E$20,5,0),"--")
F25	=IFERROR(VLOOKUP($B25&$C25&F$24,$A$10:$E$20,5,0),"--")
G25	=IFERROR(VLOOKUP($B25&$C25&G$24,$A$10:$E$20,5,0),"--")
H25	=IFERROR(VLOOKUP($B25&$C25&H$24,$A$10:$E$20,5,0),"--")

 

[kalak]

Maybe try this.

Sub make_table()

Dim d1 As Object, d2 As Object, c()
Dim a, n, u1, u2
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
a = Range("A1").CurrentRegion
n = UBound(a, 1)
ReDim c(1 To n, 1 To n)

For i = 2 To n
    u1 = a(i, 1)
    u2 = a(i, 2)
    If Not d1.exists(u1) Then d1(u1) = d1.Count + 1
    If Not d2.exists(u2) Then d2(u2) = d2.Count + 1
    c(d1(u1), d2(u2)) = c(d1(u1), d2(u2)) & " " & a(i, 3)
Next i

[e1] = [a1]
[e2].Resize(d1.Count) = Application.Transpose(d1.keys)
[f1].Resize(1, d2.Count) = d2.keys
With [f2].Resize(d1.Count, d2.Count)
    .Value = c
    .Replace "", "--", xlWhole
End With

End Sub

EDIT: This refers only to your opening post.
I didn't see your modified later data.
It does really help to say what you really want straightoff.

 

[kalak]

Modified for your modified data, including the no columns headers bit.

Sub make_table2()

Dim d1 As Object, d2 As Object, c()
Dim a, n, u1, u2
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
a = Range("A1").CurrentRegion
n = UBound(a, 1)
ReDim c(1 To n, 1 To n)

For i = 1 To n
    u1 = a(i, 1) & "|" & a(1, 2)
    u2 = a(i, 3)
    If Not d1.exists(u1) Then d1(u1) = d1.Count + 1
    If Not d2.exists(u2) Then d2(u2) = d2.Count + 1
    c(d1(u1), d2(u2)) = c(d1(u1), d2(u2)) & " " & a(i, 4)
Next i

[i1].Resize(1, d2.Count) = d2.keys
With [i2].Resize(d1.Count, d2.Count)
    .Value = c
    .Replace "", "--", xlWhole
End With
With [g2].Resize(d1.Count)
    .Value = Application.Transpose(d1.keys)
   .TextToColumns Destination:=[g2], DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, OtherChar:="|", _
         FieldInfo:=Array(Array(1, 1), Array(2, 1))
 End With

End Sub

 

[Luin29]

Thank you kalak, this is great! This code will help me with my current project and I look forward to dissecting the code to become more literate in VBA.

One more question: If I wanted the destination of this transposed summary table to be in a different worksheet, where would I place that line of code?

 

[kalak]

Thank you kalak, this is great! This code will help me with my current project and I look forward to dissecting the code to become more literate in VBA.

One more question: If I wanted the destination of this transposed summary table to be in a different worksheet, where would I place that line of code?

Try the modifications in red

Sub make_table3()

Dim d1 As Object, d2 As Object, c()
Dim a, n, u1, u2, x
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
a = Range("A1").CurrentRegion
n = UBound(a, 1)
ReDim c(1 To n, 1 To n)

For i = 1 To n
    u1 = a(i, 1) & "|" & a(1, 2)
    u2 = a(i, 3)
    If Not d1.exists(u1) Then d1(u1) = d1.Count + 1
    If Not d2.exists(u2) Then d2(u2) = d2.Count + 1
    c(d1(u1), d2(u2)) = c(d1(u1), d2(u2)) & " " & a(i, 4)
Next i

Sheets("sheet2").Activate   'CHANGE THIS DESTINATION TO WHEREVER YOU LIKE
[i1].Resize(1, d2.Count) = d2.keys
With [i2].Resize(d1.Count, d2.Count)
    .Value = c
    .Replace "", "--", xlWhole
End With
With [g2].Resize(d1.Count)
    .Value = Application.Transpose(d1.keys)
    For Each x In .Cells
        x.Resize(, 2) = Split(x, "|")
    Next x
End With

End Sub

 

[Luin29]

Thank you. The code worked great.