"Charles" wrote:

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/...ternative.html