Transpose data require VBA

[motilulla]

Hello,

I need VBA which can transpose each 4th row, 3 by 3 columns, 1st digits before "-" in the columns N:P and last digits after "-" in the columns S:U.

Example....
Cells C8, D8, E8 1st digits before "-" transpose in cells N8, N9, N10
Cells F8, G8, H8 1st digits before "-" transpose in cells O8, O9, O10
Cells I8, J8, K8 1st digits before "-" transpose in cells P8, P9, P10

Cells C8, D8, E8 last digits after "-" transpose in cells S8, S9, S10
Cells F8, G8, H8 last digits after "-" transpose in cells T8, T9, T10
Cells I8, J8, K8 last digits after "-" transpose in cells U8, U9, U10

Here is the example

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1
2
3
4
5			Col1	Col2	Col3	Col4	Col5	Col6	Col7	Col8	Col9
6
7
8		1	8 - 3	4 - 0	2 - 0	2 - 1	7 - 2	5 - 3	4 - 2	3 - 1	7 - 2		1	8	2	4		1	3	1	2
9		2	8 - 2	1 - 0	5 - 1	4 - 3	7 - 3	3 - 1	2 - 1	6 - 2	6 - 1			4	7	3			0	2	1
10		3	4 - 3	6 - 1	4 - 3	7 - 3	5 - 0	2 - 1	3 - 1	3 - 1	8 - 1			2	5	7			0	3	2
11		4	7 - 5	3 - 2	4 - 0	5 - 2	2 - 0	7 - 1	2 - 1	9 - 3	3 - 0		4	7	5	2		4	5	2	1
12		5	8 - 3	4 - 2	2 - 1	5 - 2	1 - 0	8 - 1	1 - 1	9 - 4	4 - 0			3	2	9			2	0	3
13		6	4 - 1	5 - 1	5 - 0	6 - 5	5 - 0	3 - 0	4 - 4	4 - 1	6 - 2			4	7	3			0	1	0
14		7	9 - 2	3 - 1	2 - 0	3 - 2	5 - 3	6 - 2	2 - 0	6 - 2	6 - 2		7	9	3	2		7	2	2	0
15		8	7 - 3	3 - 1	4 - 1	6 - 2	2 - 1	6 - 0	1 - 1	9 - 4	4 - 1			3	5	6			1	3	2
16		9	4 - 2	5 - 1	5 - 1	6 - 2	4 - 2	4 - 0	4 - 2	5 - 3	5 - 1			2	6	6			0	2	2
17		10	6 - 3	3 - 1	5 - 3	5 - 1	4 - 1	5 - 1	3 - 1	7 - 0	4 - 3		10	6	5	3		10	3	1	1
18		11	8 - 5	4 - 0	2 - 1	2 - 0	5 - 1	7 - 0	4 - 3	5 - 2	5 - 2			3	4	7			1	1	0
19		12	7 - 4	4 - 1	3 - 0	3 - 2	5 - 2	6 - 3	4 - 1	5 - 0	5 - 1			5	5	4			3	1	3
20		13	7 - 6	5 - 1	2 - 1	7 - 1	2 - 0	5 - 1	0 - 0	7 - 1	7 - 3		13	7	7	0		13	6	1	0
21		14	3 - 2	4 - 2	7 - 2	8 - 3	0 - 0	6 - 0	3 - 1	10 - 4	1 - 0			5	2	7			1	0	1
22		15	8 - 6	1 - 0	5 - 1	4 - 3	6 - 2	4 - 0	2 - 1	7 - 1	5 - 0			2	5	7			1	1	3
23		16	9 - 3	2 - 1	3 - 0	4 - 2	6 - 2	4 - 1	1 - 0	6 - 2	7 - 3		16	9	4	1		16	3	2	0
24		17	5 - 4	2 - 0	7 - 3	5 - 2	7 - 0	2 - 0	4 - 3	5 - 0	5 - 2			2	6	6			1	2	2
25		18	8 - 5	2 - 0	4 - 0	3 - 2	7 - 1	4 - 0	3 - 2	5 - 2	6 - 2			3	4	7			0	1	3
26		19	8 - 3	3 - 2	3 - 2	4 - 0	4 - 2	6 - 0	2 - 1	7 - 3	5 - 1		19	8	4	2		19	3	0	1
27		20	6 - 4	3 - 1	5 - 2	6 - 3	3 - 0	5 - 1	2 - 0	8 - 3	4 - 0			3	4	7			2	2	3
28		21	4 - 1	5 - 3	5 - 2	7 - 3	3 - 2	4 - 0	3 - 0	6 - 3	5 - 0			3	6	5			2	0	1
29		22	5 - 0	4 - 1	5 - 2	9 - 4	2 - 2	3 - 1	0 - 0	8 - 3	6 - 1		22	5	9	0		22	0	4	0
30		23	6 - 4	4 - 0	4 - 1	1 - 1	7 - 0	6 - 3	7 - 5	3 - 0	4 - 0			4	2	8			1	2	3
31		24	7 - 3	5 - 1	2 - 0	3 - 1	5 - 2	6 - 3	4 - 1	4 - 2	6 - 1			5	3	6			2	1	1
32		25	5 - 1	3 - 1	6 - 1	5 - 4	6 - 2	3 - 1	4 - 3	5 - 0	5 - 1		25	5	5	4		25	1	4	3
33		26	4 - 3	7 - 3	3 - 0	6 - 3	2 - 0	6 - 2	4 - 2	5 - 0	5 - 1			3	6	5			1	2	0
34		27	4 - 1	8 - 2	2 - 0	5 - 3	3 - 1	6 - 0	5 - 5	3 - 1	6 - 1			6	3	5			1	1	1
35		28	9 - 3	4 - 1	1 - 1	3 - 1	7 - 5	4 - 2	2 - 0	3 - 1	9 - 0		28	9	3	2		28	3	1	0
36		29	7 - 5	3 - 0	4 - 2	6 - 2	4 - 1	4 - 1	1 - 0	7 - 2	6 - 1			4	7	3			1	5	1
37		30	6 - 4	7 - 1	1 - 0	7 - 1	5 - 1	2 - 0	1 - 1	2 - 0	11 - 6			1	4	9			1	2	0
38		31	6 - 2	6 - 0	2 - 0	5 - 3	5 - 1	4 - 2	3 - 1	3 - 0	8 - 5		31	6	5	3		31	2	3	1
39		32	5 - 3	6 - 0	3 - 2	6 - 1	5 - 0	3 - 1	3 - 2	3 - 0	8 - 5			6	5	3			0	1	0
40		33	9 - 4	5 - 1	0 - 0	4 - 1	5 - 2	5 - 1	1 - 0	4 - 2	9 - 3			2	4	8			0	2	5
41		34	8 - 4	5 - 1	1 - 1	5 - 2	3 - 1	6 - 0	1 - 0	6 - 2	7 - 3		34	8	5	1		34	4	2	0
42		35	7 - 1	4 - 0	3 - 1	5 - 3	5 - 1	4 - 4	2 - 0	5 - 1	7 - 3			5	3	6			1	1	2
43		36	11 - 4	1 - 0	2 - 1	2 - 1	8 - 3	4 - 1	1 - 0	5 - 2	8 - 2			1	6	7			1	0	3
44		37	9 - 4	3 - 2	2 - 0	1 - 0	3 - 1	10 - 4	4 - 0	8 - 3	2 - 0		37	9	1	4		37	4	0	0
45		38	5 - 2	2 - 1	7 - 1	5 - 4	6 - 2	3 - 0	4 - 2	6 - 1	4 - 1			3	3	8			2	1	3
46		39	9 - 4	3 - 0	2 - 1	2 - 2	6 - 1	6 - 0	3 - 2	5 - 2	6 - 2			2	10	2			0	4	0
47		40	10 - 5	2 - 1	2 - 1	2 - 0	6 - 2	6 - 2	2 - 1	6 - 0	6 - 2		40	10	2	2		40	5	0	1
48														2	6	6			1	2	0
49														2	6	6			1	2	2
50
51
52
53
54
Sheet1

Thank you all
Excel 2000
Regards,
Moti

 

[Takae]

Hope this helps.

Sub test()
Dim rng As Range
Dim c, x(), z()
Dim i As Long, j As Long, k As Long, m As Long
For k = 8 To cells(Rows.count, 3).End(xlUp).Row Step 3
    m = 14
    For i = 3 To 11 Step 3
        Set rng = Range(cells(k, i), cells(k, i + 2))
        For Each c In rng
             ReDim Preserve x(j)
             x(j) = Left(c.Value, 1)
             ReDim Preserve z(j)
             z(j) = Right(c.Value, 1)
             j = j + 1
        Next
            Range(cells(k, m), cells(k + 2, m)) = WorksheetFunction.Transpose(x)
            Range(cells(k, m + 5), cells(k + 2, m + 5)) = WorksheetFunction.Transpose(z)
            j = 0
            m = m + 1
    Next
Next
End Sub

 

[motilulla]

Hope this helps.

Sub test()
Dim rng As Range
Dim c, x(), z()
Dim i As Long, j As Long, k As Long, m As Long
For k = 8 To cells(Rows.count, 3).End(xlUp).Row Step 3
    m = 14
    For i = 3 To 11 Step 3
        Set rng = Range(cells(k, i), cells(k, i + 2))
        For Each c In rng
             ReDim Preserve x(j)
             x(j) = Left(c.Value, 1)
             ReDim Preserve z(j)
             z(j) = Right(c.Value, 1)
             j = j + 1
        Next
            Range(cells(k, m), cells(k + 2, m)) = WorksheetFunction.Transpose(x)
            Range(cells(k, m + 5), cells(k + 2, m + 5)) = WorksheetFunction.Transpose(z)
            j = 0
            m = m + 1
    Next
Next
End Sub

Thank you Takae , for giving a VBA solution, it's perfect!!

Only it was transposing, H44 and C47, value instead 10 as 1
Just modified as shown below and it is fine.

For Each c In rng
             ReDim Preserve x(j)
             x(j) = Left(c.Value,[B][COLOR=#ff0000]2[/COLOR][/B])
             ReDim Preserve z(j)
             z(j) = Right(c.Value,[COLOR=#ff0000][B] 2[/B][/COLOR])
             j = j + 1
        Next

Thank you for your help

Have a nice day

Kind Regards,
Moti