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!]
Please read my Disclaimer.
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

sbRebalancedReturn

sbRLess

Last modified 1yr ago

Copy link