sbReShape
If you like to reshape a one- or two-dimensional array you can use the UDF sbReShape shown below:
[Please notice that you need to enter this function as an array-function!] 1
Function sbReShape(v As Variant, _
2
Optional bByRow As Boolean = True, _
3
Optional lColumns As Long = 1) As Variant
4
'Reverse("moc.LiborPlus.www") PB 09-Oct-2012 V0.6
5
Dim vP As Variant, vI As Variant, vR As Variant
6
Dim i(1 To 2) As Long, j As Long
7
Dim k(1 To 2) As Long, rc(1 To 2) As Long
8
9
With Application.WorksheetFunction
10
vP = .Transpose(.Transpose(v))
11
End With
12
13
With Application.Caller
14
j = 2 + bByRow
15
If TypeName(Application.Caller) = "Range" Then
16
rc(1) = .Columns.Count
17
rc(2) = .Rows.Count
18
Else
19
rc(1) = lColumns
20
rc(2) = 1
21
End If
22
ReDim vR(1 To rc(1), 1 To rc(2))
23
i(1) = 1
24
i(2) = 1
25
For Each vI In v
26
vR(i(3 - j), i(j)) = vI
27
i(2) = i(2) + 1
28
If i(2) > rc(j) Then
29
i(2) = 1
30
i(1) = i(1) + 1
31
If i(1) > rc(3 - j) Then
32
sbReShape = Application.WorksheetFunction.Transpose(vR)
33
Exit Function
34
End If
35
End If
36
Next vI
37
fillcverrval:
38
vR(i(3 - j), i(j)) = CVErr(xlErrValue)
39
i(2) = i(2) + 1
40
If i(2) > rc(j) Then
41
i(2) = 1
42
i(1) = i(1) + 1
43
If i(1) > rc(3 - j) Then
44
sbReShape = Application.WorksheetFunction.Transpose(vR)
45
Exit Function
46
End If
47
End If
48
GoTo fillcverrval
49
End With
50
End Function
Copied!
sbReShape.xlsm
15KB
Binary
sbReShape.xlsm