VBA Transpose data from one sheet into another

[madi1004]

Hello,

I need your support in creating a vba and transposing data into another sheet

Original sheet from where the data is needed to be copied

VBA Transpose.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY
1	rate zone code	rate zone name	origin address	destination address	currency	1 Pal	2 Pal	3 Pal	4 Pal	5 Pal	6 Pal	7 Pal	8 Pal	9 Pal	10 Pal	11 Pal	12 Pal	13 Pal	14 Pal	15 Pal	16 Pal	17 Pal	18 Pal	19 Pal	20 Pal	21 Pal	22 Pal	23 Pal	24 Pal	25 Pal	26 Pal	27 Pal	28 Pal	29 Pal	30 Pal	31 Pal	32 Pal	33 Pal	34 Pal	35 Pal	36 Pal	37 Pal	38 Pal	39 Pal	40 Pal	45 Pal	50 Pal	55 Pal	60 Pal	Lead time door to door [hours]	Comments
2	ratezone code 1	ratezone name 1	origin address 1	destination address 1	USD	60	110	160	210	260	310	360	410	460	510	560	610	660	710	760	810	860	910	960	1010	1060	1110	1160	1210	1260	1310	1360	1410	1460	1510	1560	1610	1660	1710	1760	1810	1860	1910	1960	2010	2060	2110	2160	2210	24 h	comment 1
3	ratezone code 2	ratezone name 2	origin address 2	destination address 2	USD	80	130	180	230	280	330	380	430	480	530	580	630	680	730	780	830	880	930	980	1030	1080	1130	1180	1230	1280	1330	1380	1430	1480	1530	1580	1630	1680	1730	1780	1830	1880	1930	1980	2030	2080	2130	2180	2230	48 h	comment 2
4	ratezone code 3	ratezone name 3	origin address 3	destination address 3	USD	90	140	190	240	290	340	390	440	490	540	590	640	690	740	790	840	890	940	990	1040	1090	1140	1190	1240	1290	1340	1390	1440	1490	1540	1590	1640	1690	1740	1790	1840	1890	1940	1990	2040	2090	2140	2190	2240	72 h	comment 3
5	ratezone code 4	ratezone name 4	origin address 4	destination address 4	USD	100	150	200	250	300	350	400	450	500	550	600	650	700	750	800	850	900	950	1000	1050	1100	1150	1200	1250	1300	1350	1400	1450	1500	1550	1600	1650	1700	1750	1800	1850	1900	1950	2000	2050	2100	2150	2200	2250	93 h	comment 4
6	ratezone code 5	ratezone name 5	origin address 5	destination address 5	USD	150	200	250	300	350	400	450	500	550	600	650	700	750	800	850	900	950	1000	1050	1100	1150	1200	1250	1300	1350	1400	1450	1500	1550	1600	1650	1700	1750	1800	1850	1900	1950	2000	2050	2100	2150	2200	2250	2300	48 h	comment 5
LTL

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A2,A4,A6	Expression	=LEN(A2)>32	text	NO
B2:B6	Expression	=LEN(B2)>64	text	NO

And I would need your help to create a VBA code to transpose the data and at the end to look like this

VBA Transpose.xlsx
	A	B	C	D
1	rate zone code	from pallet	to pallet	rate
2	ratezone code 1	1	1	60
3	ratezone code 1	2	2	110
4	ratezone code 1	3	3	160
5	ratezone code 1	4	4	210
6	ratezone code 1	5	5	260
7	ratezone code 1	6	6	310
8	ratezone code 1	7	7	360
9	ratezone code 1	8	8	410
10	ratezone code 1	9	9	460
11	ratezone code 1	10	10	510
12	ratezone code 1	11	11	560
13	ratezone code 1	12	12	610
14	ratezone code 1	13	13	660
15	ratezone code 1	14	14	710
16	ratezone code 1	15	15	760
17	ratezone code 1	16	16	810
18	ratezone code 1	17	17	860
19	ratezone code 1	18	18	910
20	ratezone code 1	19	19	960
21	ratezone code 1	20	20	1010
22	ratezone code 1	21	21	1060
23	ratezone code 1	22	22	1110
24	ratezone code 1	23	23	1160
25	ratezone code 1	24	24	1210
26	ratezone code 1	25	25	1260
27	ratezone code 1	26	26	1310
28	ratezone code 1	27	27	1360
29	ratezone code 1	28	28	1410
30	ratezone code 1	29	29	1460
31	ratezone code 1	30	30	1510
32	ratezone code 1	31	31	1560
33	ratezone code 1	32	32	1610
34	ratezone code 1	33	33	1660
35	ratezone code 1	34	34	1710
36	ratezone code 1	35	35	1760
37	ratezone code 1	36	36	1810
38	ratezone code 1	37	37	1860
39	ratezone code 1	38	38	1910
40	ratezone code 1	39	39	1960
41	ratezone code 1	40	40	2010
42	ratezone code 1	45	45	2060
43	ratezone code 1	50	50	2110
44	ratezone code 1	55	55	2160
45	ratezone code 1	60	60	2210
46	ratezone code 2	1	1	80
47	ratezone code 2	2	2	130
48	ratezone code 2	3	3	180
49	ratezone code 2	4	4	230
50	ratezone code 2	5	5	280
51	ratezone code 2	6	6	330
52	ratezone code 2	7	7	380
53	ratezone code 2	8	8	430
54	ratezone code 2	9	9	480
55	ratezone code 2	10	10	530
56	ratezone code 2	11	11	580
57	ratezone code 2	12	12	630
58	ratezone code 2	13	13	680
59	ratezone code 2	14	14	730
60	ratezone code 2	15	15	780
61	ratezone code 2	16	16	830
62	ratezone code 2	17	17	880
63	ratezone code 2	18	18	930
64	ratezone code 2	19	19	980
65	ratezone code 2	20	20	1030
66	ratezone code 2	21	21	1080
67	ratezone code 2	22	22	1130
68	ratezone code 2	23	23	1180
69	ratezone code 2	24	24	1230
70	ratezone code 2	25	25	1280
71	ratezone code 2	26	26	1330
72	ratezone code 2	27	27	1380
73	ratezone code 2	28	28	1430
74	ratezone code 2	29	29	1480
75	ratezone code 2	30	30	1530
76	ratezone code 2	31	31	1580
77	ratezone code 2	32	32	1630
78	ratezone code 2	33	33	1680
79	ratezone code 2	34	34	1730
80	ratezone code 2	35	35	1780
81	ratezone code 2	36	36	1830
82	ratezone code 2	37	37	1880
83	ratezone code 2	38	38	1930
84	ratezone code 2	39	39	1980
85	ratezone code 2	40	40	2030
86	ratezone code 2	45	45	2080
87	ratezone code 2	50	50	2130
88	ratezone code 2	55	55	2180
89	ratezone code 2	60	60	2230
90	ratezone code 3	1	1	90
91	ratezone code 3	2	2	140
92	ratezone code 3	3	3	190
93	ratezone code 3	4	4	240
94	ratezone code 3	5	5	290
95	ratezone code 3	6	6	340
96	ratezone code 3	7	7	390
97	ratezone code 3	8	8	440
98	ratezone code 3	9	9	490
99	ratezone code 3	10	10	540
100	ratezone code 3	11	11	590
101	ratezone code 3	12	12	640
102	ratezone code 3	13	13	690
103	ratezone code 3	14	14	740
104	ratezone code 3	15	15	790
105	ratezone code 3	16	16	840
106	ratezone code 3	17	17	890
107	ratezone code 3	18	18	940
108	ratezone code 3	19	19	990
109	ratezone code 3	20	20	1040
110	ratezone code 3	21	21	1090
111	ratezone code 3	22	22	1140
112	ratezone code 3	23	23	1190
113	ratezone code 3	24	24	1240
114	ratezone code 3	25	25	1290
115	ratezone code 3	26	26	1340
116	ratezone code 3	27	27	1390
117	ratezone code 3	28	28	1440
118	ratezone code 3	29	29	1490
119	ratezone code 3	30	30	1540
120	ratezone code 3	31	31	1590
121	ratezone code 3	32	32	1640
122	ratezone code 3	33	33	1690
123	ratezone code 3	34	34	1740
124	ratezone code 3	35	35	1790
125	ratezone code 3	36	36	1840
126	ratezone code 3	37	37	1890
127	ratezone code 3	38	38	1940
128	ratezone code 3	39	39	1990
129	ratezone code 3	40	40	2040
130	ratezone code 3	45	45	2090
131	ratezone code 3	50	50	2140
132	ratezone code 3	55	55	2190
133	ratezone code 3	60	60	2240
134	ratezone code 4	1	1	100
135	ratezone code 4	2	2	150
136	ratezone code 4	3	3	200
137	ratezone code 4	4	4	250
138	ratezone code 4	5	5	300
139	ratezone code 4	6	6	350
140	ratezone code 4	7	7	400
141	ratezone code 4	8	8	450
142	ratezone code 4	9	9	500
143	ratezone code 4	10	10	550
144	ratezone code 4	11	11	600
145	ratezone code 4	12	12	650
146	ratezone code 4	13	13	700
147	ratezone code 4	14	14	750
148	ratezone code 4	15	15	800
149	ratezone code 4	16	16	850
150	ratezone code 4	17	17	900
151	ratezone code 4	18	18	950
152	ratezone code 4	19	19	1000
153	ratezone code 4	20	20	1050
154	ratezone code 4	21	21	1100
155	ratezone code 4	22	22	1150
156	ratezone code 4	23	23	1200
157	ratezone code 4	24	24	1250
158	ratezone code 4	25	25	1300
159	ratezone code 4	26	26	1350
160	ratezone code 4	27	27	1400
161	ratezone code 4	28	28	1450
162	ratezone code 4	29	29	1500
163	ratezone code 4	30	30	1550
164	ratezone code 4	31	31	1600
165	ratezone code 4	32	32	1650
166	ratezone code 4	33	33	1700
167	ratezone code 4	34	34	1750
168	ratezone code 4	35	35	1800
169	ratezone code 4	36	36	1850
170	ratezone code 4	37	37	1900
171	ratezone code 4	38	38	1950
172	ratezone code 4	39	39	2000
173	ratezone code 4	40	40	2050
174	ratezone code 4	45	45	2100
175	ratezone code 4	50	50	2150
176	ratezone code 4	55	55	2200
177	ratezone code 4	60	60	2250
178	ratezone code 5	1	1	150
179	ratezone code 5	2	2	200
180	ratezone code 5	3	3	250
181	ratezone code 5	4	4	300
182	ratezone code 5	5	5	350
183	ratezone code 5	6	6	400
184	ratezone code 5	7	7	450
185	ratezone code 5	8	8	500
186	ratezone code 5	9	9	550
187	ratezone code 5	10	10	600
188	ratezone code 5	11	11	650
189	ratezone code 5	12	12	700
190	ratezone code 5	13	13	750
191	ratezone code 5	14	14	800
192	ratezone code 5	15	15	850
193	ratezone code 5	16	16	900
194	ratezone code 5	17	17	950
195	ratezone code 5	18	18	1000
196	ratezone code 5	19	19	1050
197	ratezone code 5	20	20	1100
198	ratezone code 5	21	21	1150
199	ratezone code 5	22	22	1200
200	ratezone code 5	23	23	1250
201	ratezone code 5	24	24	1300
202	ratezone code 5	25	25	1350
203	ratezone code 5	26	26	1400
204	ratezone code 5	27	27	1450
205	ratezone code 5	28	28	1500
206	ratezone code 5	29	29	1550
207	ratezone code 5	30	30	1600
208	ratezone code 5	31	31	1650
209	ratezone code 5	32	32	1700
210	ratezone code 5	33	33	1750
211	ratezone code 5	34	34	1800
212	ratezone code 5	35	35	1850
213	ratezone code 5	36	36	1900
214	ratezone code 5	37	37	1950
215	ratezone code 5	38	38	2000
216	ratezone code 5	39	39	2050
217	ratezone code 5	40	40	2100
218	ratezone code 5	45	45	2150
219	ratezone code 5	50	50	2200
220	ratezone code 5	55	55	2250
221	ratezone code 5	60	60	2300
Transpose VBA

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A2:A221	Expression	=LEN(A2)>32	text	NO

Thank you

 

[skillilea]

Have you looked at power query. It does this quite well?

 

[madi1004]

I would prefer VBA, as it is part of a bigger project

 

[skillilea]

Try this

Sub TransposeAndFormatData()
    Dim ws As Worksheet
    Dim sourceRange As Range, destRange As Range
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long, rowIndex As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet10") ' Replace "Sheet1" with the actual sheet name
    
    ' last rows/cols
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    Set sourceRange = ws.Range(ws.Cells(2, 6), ws.Cells(lastRow, lastCol))
    
    Set destRange = ws.Cells(14, 1) ' might put this on a seperate sheet, just below my sample data now
    
    For i = 1 To sourceRange.Rows.Count
        For j = 1 To sourceRange.Columns.Count
            rowIndex = (i - 1) * sourceRange.Columns.Count + j
            
            ' write out
            destRange.Offset(rowIndex - 1, 0).Value = ws.Cells(i + 1, 1).Value
            destRange.Offset(rowIndex - 1, 1).Value = j
            destRange.Offset(rowIndex - 1, 2).Value = j
            destRange.Offset(rowIndex - 1, 3).Value = sourceRange.Cells(i, j).Value
        Next
    Next
    
    'headers
    ws.Cells(14 - 1, 1).Value = "rate zone code"
    ws.Cells(14 - 1, 2).Value = "from pallet"
    ws.Cells(14 - 1, 3).Value = "to pallet"
    ws.Cells(14 - 1, 4).Value = "rate"
End Sub

 

[madi1004]

I have found something, but still need your support:

Sub Transpose()

  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  Dim bln As Boolean
  
  a = Sheets("LTL").Range("A1").CurrentRegion
  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 2)
  
  k = 1
  For i = 2 To UBound(a, 1)
    bln = False
    For j = 6 To UBound(a, 2)
      b(k, 1) = a(i, 1)
      If a(i, j) <> "" Then
        b(k, 2) = a(i, j)
        k = k + 1
        bln = True
      End If
    Next
    If bln = False Then k = k + 1
  Next
  Sheets("Transposed").Range("A2").Resize(k, 2).Value = b
End Sub

It takes in consideration also the last 2 columns, from the first sheet, which I don't need .

It does not transpose the columns with the pallets (1-60).

 

[skillilea]

Did you try the code in post #4 above?

 

[madi1004]

Did you try the code in post #4 above?

yes, I tried it now thank you.

I did some changes, for the last 2 columns as they are not needed , and also as you mentioned regarding the second sheet

ub Transposedata()

    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim sourceRange As Range, destRange As Range
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long, rowIndex As Long
    
    Set ws = ThisWorkbook.Sheets("LTL") ' Replace "Sheet1" with the actual sheet name
    Set ws2 = ThisWorkbook.Sheets("Transposed")
    ' last rows/cols
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column - 2
    
    Set sourceRange = ws.Range(ws.Cells(2, 6), ws.Cells(lastRow, lastCol))
    
    Set destRange = ws2.Cells(2, 1) ' might put this on a seperate sheet, just below my sample data now
    
    For i = 1 To sourceRange.Rows.Count
        For j = 1 To sourceRange.Columns.Count
            rowIndex = (i - 1) * sourceRange.Columns.Count + j
            
            ' write out
            destRange.Offset(rowIndex - 1, 0).Value = ws.Cells(i + 1, 1).Value
            destRange.Offset(rowIndex - 1, 1).Value = j
            destRange.Offset(rowIndex - 1, 2).Value = j
            destRange.Offset(rowIndex - 1, 3).Value = sourceRange.Cells(i, j).Value
        Next
    Next
    
    'headers
    ws2.Cells(1, 1).Value = "rate zone code"
    ws2.Cells(1, 2).Value = "from pallet"
    ws2.Cells(1, 3).Value = "to pallet"
    ws2.Cells(1, 4).Value = "rate"
End Sub

The issue that I have now, is regarding the last pallets, as now it is considering 40-44, but my last pallets are 40, 45, 50 , 55 , 60
Can you please take a look also on this.
Maybe there is a possibility to copy / transpose from F1 to AW1 - as the format of the cell is a number.

Regards,
Dieter

 

[skillilea]

I'm out for the rest of the day. Bump this if it's not solved by tomorrow and I'll look at it.

I would probably change the approach to an array if you have a ton of rate zone codes.

 

[Coyotex3]

Hi, give this code a try on a copy of your workbook

Sub Pallets()
Dim sh1 As Worksheet, sht As Worksheet
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  Dim lr As Long
 
Sheets.Add.Name = "Temp"  'adds a sheet named Temp
  Set sh1 = Sheets("LTL") ' Change this name to the name of your sheet.
  Set sht = Sheets("Temp")
 
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row

  a = sh1.Range("A1:AW" & lr).Value
  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 4)
 
  For i = 2 To UBound(a, 1)
        For j = 6 To UBound(a, 2)
        k = k + 1

            b(k, 1) = a(i, 1)
            b(k, 2) = a(1, j)
            b(k, 3) = a(1, j)
            b(k, 4) = a(i, j)
   
    Next
   Next
   sht.Range("A2").Resize(k, 4).Value = b
 Range("A1:D1").Value = Array("Rate Zone Code", "From Pallet", "To Pallet", "Rate")
End Sub

 

[madi1004]

Hi, give this code a try on a copy of your workbook

Sub Pallets()
Dim sh1 As Worksheet, sht As Worksheet
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  Dim lr As Long
 
Sheets.Add.Name = "Temp"  'adds a sheet named Temp
  Set sh1 = Sheets("LTL") ' Change this name to the name of your sheet.
  Set sht = Sheets("Temp")
 
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row

  a = sh1.Range("A1:AW" & lr).Value
  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 4)
 
  For i = 2 To UBound(a, 1)
        For j = 6 To UBound(a, 2)
        k = k + 1

            b(k, 1) = a(i, 1)
            b(k, 2) = a(1, j)
            b(k, 3) = a(1, j)
            b(k, 4) = a(i, j)
  
    Next
   Next
   sht.Range("A2").Resize(k, 4).Value = b
 Range("A1:D1").Value = Array("Rate Zone Code", "From Pallet", "To Pallet", "Rate")
End Sub

Thank you for your support.
It works now