Converting a grid of data to linear

[Charles]

I need to transpose a grid of data into a linear format, a cut of the
existing data looks like this:

B C D E
1 35714.57 0 0 34365.98
2 23874.54 0 23843.06 22860.84
3 44657.62 0 0 42872.15
4 33940.83 0 0 33940.83
5 52097.52 0 0 50002.48
6 32843.55 0 0 32843.55
7 36063.75 0 0 36063.75
8 35093.81 0 0 35093.81
9 10873.63 0 0 10873.63
And I want it to look like this:

1 35714.57
1 0
1 0
1 34365.98
1 0
1 35714.57
2 23874.54
2 0
2 23843.06
2 22860.84
2 0
2 23874.54

The existing data extend to 20 or more columns and there will be 9000 rows.

Any suggestions gratefully received.

Thanks

 

[Patrick Molloy]

something quite simple like this to get you started....


Option Explicit

Sub Rearrange()
Dim lastRow As Long
Dim cl As Long
'get depth of column
lastRow = Range("A1").End(xlDown).Row
For cl = 2 To 20
Range("A1").End(xlDown).Offset(1).Select
Range(Cells(1, cl), Cells(lastRow, cl)).Cut
ActiveSheet.Paste
Next
End Sub

 

[Joel]

I don't think this is exactly right. It don't know if you want any formulas
put into the worksheet to automatically sum columns and I don't know which
columns the zeroes in the input match the zeroes in the output. the code
copies the data from sheet 1 to sheet 2. change as required.

Sub ColumnsToRows()

Set SourceSht = Sheets("Sheet1")
Set DestSht = Sheets("Sheet2")

NewRow = 1
With SourceSht
RowCount = 1
ItemNum = 1
Do While .Range("A" & RowCount) <> ""
Col_B = .Range("B" & RowCount)
Col_C = .Range("C" & RowCount)
Col_D = .Range("D" & RowCount)
Col_E = .Range("E" & RowCount)
With DestSht
.Range("A" & NewRow & ":A" & (NewRow + 6)) = ItemNum
.Range("B" & NewRow) = Col_B
.Range("B" & (NewRow + 1)) = Col_C
.Range("B" & (NewRow + 2)) = Col_D
.Range("B" & (NewRow + 3)) = Col_E
.Range("B" & (NewRow + 4)) = Col_C
.Range("B" & (NewRow + 5)) = Col_B

NewRow = NewRow + 6
End With
ItemNum = ItemNum + 1
RowCount = RowCount + 1
Loop
End With
End Sub

 

[r]

I need to transpose a grid of data into a linear format, a cut of the
existing data looks like this:

B C D E
1 35714.57 0 0 34365.98
2 23874.54 0 23843.06 22860.84
3 44657.62 0 0 42872.15
4 33940.83 0 0 33940.83
5 52097.52 0 0 50002.48
6 32843.55 0 0 32843.55
7 36063.75 0 0 36063.75
8 35093.81 0 0 35093.81
9 10873.63 0 0 10873.63
And I want it to look like this:

1 35714.57
1 0
1 0
1 34365.98
1 0
1 35714.57
2 23874.54
2 0
2 23843.06
2 22860.84
2 0
2 23874.54

The existing data extend to 20 or more columns and there will be 9000 rows.

Sub ShowTwst()
Test_1 [a1:d4]
End Sub

Sub Test_1(rng As Excel.Range)
Dim v()
Dim res()
Dim R As Long, C As Long, L1 As Long, L2 As Long
Dim i As Long
Dim DestRng As Excel.Range

v = rng

R = UBound(v, 1)
C = UBound(v, 2)
ReDim res(1 To R * (C - 1), 1 To 2)

For L1 = 1 To R
For L2 = 2 To C
i = i + 1
res(i, 1) = v(L1, 1)
res(i, 2) = v(L1, L2)
Next L2
Next L1

Set DestRng = Nuovo_Range(ThisWorkbook)
DestRng.Resize(R * (C - 1), 2) = res


End Sub

Function Nuovo_Range( _
Wb As Excel.Workbook, _
Optional Nome_base As _
String = "Res") As Excel.Range

'restituisce la cella A1 di un nuovo foglio
'il nuovo foglio viene rinominato in base
'all'argomento Nome_base

Dim b As Long
Set Nuovo_Range = Wb.Worksheets.Add.Range("A1")

Application.ScreenUpdating = False
On Error Resume Next
Do
Err.Clear
b = b + 1
Nuovo_Range.Parent.Name = Nome_base & b
Loop While Err
Application.ScreenUpdating = True

End Function


regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html

 

[Charles]

Hi Patrick

Thanks, this is a good start; but at the moment it is moving everything to
column A

I need list the entries in Row1 one below the other, then take Row 2 and
list them below the Row1 data one after the other.

Regards

Charles

 

[Patrick Molloy]

column by column. yes. the following is probably better for you...sorry

Option Explicit
Sub Rearrange2()
Dim lastRow As Long
Dim cl As Long
Dim ws As Worksheet
Dim wsThis As Worksheet
Dim rw As Long
Dim lastCol As Long

Set wsThis = ActiveSheet
Set ws = Worksheets.Add(Worksheets(1))
lastRow = wsThis.Range("A1").End(xlDown).Row
lastCol = wsThis.Range("A1").End(xlToRight).Column

For rw = 1 To lastRow
wsThis.Range(wsThis.Cells(rw, 1), wsThis.Cells(rw, lastCol)).Copy
ws.Range("A65000").End(xlUp).Offset(1).PasteSpecial xlPasteValues, ,
, Transpose:=True
Next
End Sub

 

[Charles]

Hi Patrick, Joel and R

Thanks for all the instant help. All three solutions work for me, if I do a
couple of minor tweaks.

I hope you all know how much I appreciate your help!

Regards

Charles

I need to transpose a grid of data into a linear format, a cut of the
existing data looks like this:

B C D E
1 35714.57 0 0 34365.98
2 23874.54 0 23843.06 22860.84
3 44657.62 0 0 42872.15
4 33940.83 0 0 33940.83
5 52097.52 0 0 50002.48
6 32843.55 0 0 32843.55
7 36063.75 0 0 36063.75
8 35093.81 0 0 35093.81
9 10873.63 0 0 10873.63
And I want it to look like this:

1 35714.57
1 0
1 0
1 34365.98
1 0
1 35714.57
2 23874.54
2 0
2 23843.06
2 22860.84
2 0
2 23874.54

The existing data extend to 20 or more columns and there will be 9000 rows.

Sub ShowTwst()
Test_1 [a1:d4]
End Sub

Sub Test_1(rng As Excel.Range)
Dim v()
Dim res()
Dim R As Long, C As Long, L1 As Long, L2 As Long
Dim i As Long
Dim DestRng As Excel.Range

v = rng

R = UBound(v, 1)
C = UBound(v, 2)
ReDim res(1 To R * (C - 1), 1 To 2)

For L1 = 1 To R
For L2 = 2 To C
i = i + 1
res(i, 1) = v(L1, 1)
res(i, 2) = v(L1, L2)
Next L2
Next L1

Set DestRng = Nuovo_Range(ThisWorkbook)
DestRng.Resize(R * (C - 1), 2) = res


End Sub

Function Nuovo_Range( _
Wb As Excel.Workbook, _
Optional Nome_base As _
String = "Res") As Excel.Range

'restituisce la cella A1 di un nuovo foglio
'il nuovo foglio viene rinominato in base
'all'argomento Nome_base

Dim b As Long
Set Nuovo_Range = Wb.Worksheets.Add.Range("A1")

Application.ScreenUpdating = False
On Error Resume Next
Do
Err.Clear
b = b + 1
Nuovo_Range.Parent.Name = Nome_base & b
Loop While Err
Application.ScreenUpdating = True

End Function


regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html