VBA ВПР/группа по к зубчатому массиву

Question

Скажет, у меня есть две колонок A и B в моей таблице:

A  B 
0.2  1 
0.0  1 
0.5  2 
0.7  3 
1.5  3 
2.7  3 
0.1  4 

Как преобразовать это в рваный массив на основе значения B таким образом, что

arr = [[0.2, 0.0], 
     [0.5], 
     [0.7, 1.5, 2.7], 
     [0.1]] 

Answer 1

Это то, что я сделал:

Dim uniqueT() As Variant: uniqueT = DistinctValues(Application.Transpose(Range("arrT"))) 
Dim nMaturities As Integer: nMaturities = UBound(uniqueT) 
Dim nKnots As Integer, row As Integer 

Dim K() As Variant: ReDim K(1 To nMaturities) 
Dim mids() As Variant: ReDim mids(1 To nMaturities) 

With Application.WorksheetFunction 
    For i = 1 To nMaturities 
     nKnots = .CountIf(Range("arrT"), "=" & uniqueT(i)) 
     row = .Match(uniqueT(i), Range("arrT"), False) - 1 
     K(i) = .Transpose(Range("arrK").Cells(1).Offset(row, 0).Resize(nKnots, 1)) 
     mids(i) = .Transpose(Range("arrMid").Cells(1).Offset(row, 0).Resize(nKnots, 1)) 
    Next i 
End With 

Answer 2

Я не думаю, что вы получите зубчатый массив, но ниже предоставит вам пространство с максимальным числом и пробелами, если нет значений.

Sub jag_array() 

    Dim maxcolb As Long, countcolb As Long, arr() As Variant 
    maxcolb = Application.Max(Columns(2)) 
    countcolb = 1 

    ReDim arr(1 To maxcolb, 1 To countcolb) As Variant 
    'cycle through all values eg 1 to 4 
    For i = 1 To maxcolb 

     'expand the array as required 
     If Application.CountIf(Columns(2), i) > countcolb Then 

      countcolb = Application.CountIf(Columns(2), i) 
      ReDim Preserve arr(1 To UBound(arr, 1), 1 To countcolb) As Variant 


     End If 

     'find and cycle through all found column b 
     Set c = Columns(2).Find(i, After:=Cells(1, 2), LookIn:=xlValues) 
     If Not c Is Nothing Then 

      j = 1 
      firstAddress = c.Address 
      Do 
       'add column a value 
       arr(i, j) = Cells(c.Row, 1).Value 
       j = j + 1 
       Set c = Columns(2).FindNext(c) 

       If c Is Nothing Then Exit Do 
      Loop While c.Address <> firstAddress 
     End If 
    Next 

'use arr(x, y) as you need to 

End Sub