Transposing data with Loop

L

Luin29

New Member
Joined
Oct 7, 2015
Messages
45
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:

[TABLE="width: 608"]
<tbody>[TR]
[TD]Store[/TD]
[TD]Item[/TD]
[TD]Number Sold[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A1[/TD]
[TD]Baseballs[/TD]
[TD]20[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A1[/TD]
[TD]Bats[/TD]
[TD]5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A1[/TD]
[TD]Shorts[/TD]
[TD]35[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A1[/TD]
[TD]Volleyballs[/TD]
[TD]12[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A1[/TD]
[TD]Tennis Rackets[/TD]
[TD]15[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A1[/TD]
[TD]Swim Trunks[/TD]
[TD]10[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B16[/TD]
[TD]Baseballs[/TD]
[TD]22[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B16[/TD]
[TD]Bats[/TD]
[TD]8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B16[/TD]
[TD]Shorts[/TD]
[TD]45[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B16[/TD]
[TD]Volleyballs[/TD]
[TD]6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B16[/TD]
[TD]Tennis Rackets[/TD]
[TD]7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B16[/TD]
[TD]Swim Trunks[/TD]
[TD]5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]B16[/TD]
[TD]Gloves[/TD]
[TD]2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Into this:
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Store[/TD]
[TD]Baseballs[/TD]
[TD]Bats[/TD]
[TD]Shorts[/TD]
[TD]Volleyballs[/TD]
[TD]Tennis Rackets[/TD]
[TD]Swim Trunks[/TD]
[TD]Gloves[/TD]
[/TR]
[TR]
[TD]A1[/TD]
[TD]20[/TD]
[TD]5[/TD]
[TD]35[/TD]
[TD]12[/TD]
[TD]15[/TD]
[TD]10[/TD]
[TD]--[/TD]
[/TR]
[TR]
[TD]B16[/TD]
[TD]22[/TD]
[TD]8[/TD]
[TD]45[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]5[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]



Here is what I have so far:

Code: 
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
 
Last edited:
Sort by date Sort by votes
without VBA,

with a pivot table.


Book1
ABCDEFGHIJKLMN
12StoreItemNumber Sold
13A1Baseballs20Som van Number SoldKolomlabels
14A1Bats5RijlabelsBaseballsBatsGlovesShortsSwim TrunksTennis RacketsVolleyballsEindtotaal
15A1Shorts35A12053510151297
16A1Volleyballs12B1622824557695
17A1Tennis Rackets15Eindtotaal4213280152218192
18A1Swim Trunks10
19
20B16Baseballs22
21B16Bats8
22B16Shorts45
23B16Volleyballs6
24B16Tennis Rackets7
25B16Swim Trunks5
26B16Gloves2
27
Blad25
 
Upvote 0
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:

[TABLE="width: 299"]
<tbody>[TR]
[TD]1A[/TD]
[TD]09/03/15[/TD]
[TD]Benzene[/TD]
[TD]ND<0.5[/TD]
[/TR]
[TR]
[TD]1A[/TD]
[TD]09/03/15[/TD]
[TD]1,1-Dichloroethane[/TD]
[TD]3.3[/TD]
[/TR]
[TR]
[TD]1A[/TD]
[TD]09/03/15[/TD]
[TD]1,2-Dichloroethane[/TD]
[TD]ND<0.5[/TD]
[/TR]
[TR]
[TD]1A[/TD]
[TD]09/03/15[/TD]
[TD]Trichloroethene[/TD]
[TD]1.1[/TD]
[/TR]
[TR]
[TD]1A[/TD]
[TD]09/03/15[/TD]
[TD]Vinyl Chloride[/TD]
[TD]ND<0.5[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]3C[/TD]
[TD]09/06/15[/TD]
[TD]1,1-Dichloroethane[/TD]
[TD] 5.9[/TD]
[/TR]
[TR]
[TD]3C[/TD]
[TD]09/06/15[/TD]
[TD]1,2-Dichloroethane[/TD]
[TD]ND<0.5[/TD]
[/TR]
[TR]
[TD]3C[/TD]
[TD]09/06/15[/TD]
[TD]Trichloroethene[/TD]
[TD]3.5[/TD]
[/TR]
[TR]
[TD]3C[/TD]
[TD]09/06/15[/TD]
[TD]Vinyl Chloride[/TD]
[TD]ND<0.5[/TD]
[/TR]
</tbody><colgroup><col><col><col><col></colgroup>[/TABLE]

Into this:

[TABLE="width: 402"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD]Benzene[/TD]
[TD]1,1-Dichloroethane[/TD]
[TD]1,2-Dichloroethane[/TD]
[TD]Trichloroethene[/TD]
[TD]Vinyl Chloride[/TD]
[/TR]
[TR]
[TD]1A[/TD]
[TD]09/03/15[/TD]
[TD]ND<0.5[/TD]
[TD]3.3[/TD]
[TD]ND<0.5[/TD]
[TD]1.1[/TD]
[TD]ND<0.5[/TD]
[/TR]
[TR]
[TD]3C[/TD]
[TD]09/06/15[/TD]
[TD]--[/TD]
[TD]5.9[/TD]
[TD]ND<0.5[/TD]
[TD]3.5[/TD]
[TD]ND<0.5[/TD]
[/TR]
</tbody><colgroup><col><col><col span="5"></colgroup>[/TABLE]

Thanks.
 
Upvote 0
Maybe like this.


Book1
ABCDEFGH
10helpnumberdatenamesub name
111A42072Benzene1A9-3-2015BenzeneND<0.5
121A420721,1-Dichloroethane1A9-3-20151,1-Dichloroethane3.3
131A420721,2-Dichloroethane1A9-3-20151,2-DichloroethaneND<0.5
141A42072Trichloroethene1A9-3-2015Trichloroethene1.1
151A42072Vinyl Chloride1A9-3-2015Vinyl ChlorideND<0.5
16
173C421641,1-Dichloroethane3C9-6-20151,1-Dichloroethane5.9
183C421641,2-Dichloroethane3C9-6-20151,2-DichloroethaneND<0.5
193C42164Trichloroethene3C9-6-2015Trichloroethene3.5
203C42164Vinyl Chloride3C9-6-2015Vinyl ChlorideND<0.5
21
22Into this:
23
24Benzene1,1-Dichloroethane1,2-DichloroethaneTrichloroetheneVinyl Chloride
251A9-3-2015ND<0.53.3ND<0.51.1ND<0.5
263C9-6-2015--5.9ND<0.53.5ND<0.5
27
Blad25
Cell Formulas
RangeFormula
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),"--")
 
Upvote 0
Luin29;452s[/QUOTE said:
Maybe try this.
Code: 
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.
Click to expand...
 
Last edited:
Upvote 0
Modified for your modified data, including the no columns headers bit.
Code: 
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
 
Upvote 0
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?
 
Upvote 0
Luin29 said:
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?
Click to expand...
Try the modifications in red
Rich (BB code): 
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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Copy or Transpose multiple columns into a single column.
Replies
2
Views
126
harzer
H
gtd526
  • Solved
Modify Conditional Formatting to include Odd and Even rows
Replies
4
Views
131
Peter_SSs
Peter_SSs
ExcelNewbie2020
  • Solved
transpose data
2
Replies
15
Views
648
kvsrinivasamurthy
K
M
  • Solved
VBA Transpose data from one sheet into another
Replies
9
Views
667
madi1004
M
D
  • Question Question
VBA code to transpose data from vertical to horizontal based on certain conditions.
Replies
2
Views
125
dsubash
D

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top