使用两个数组排序到表

Question

在我试图解释困境时请耐心等待。我正在尝试编写一个宏来帮助我对下表进行排序：

并尝试使用这些预先格式化的表将销售ID排序到另一个工作表（在同一工作簿中）：

最终结果应如下图所示，我需要做的就是填写销售ID，并在销售ID列右侧的公式计算或执行查找：

问题是我的团队一直在手动填写表格，或者使用sort函数的组合来手动填写表格。问题是当我们有10,000多个销售ID而没有自动化时，这可能会很痛苦。我尝试编码以帮助我的团队没有得到我有限的vba知识的帮助 - 任何帮助表示赞赏：

编辑：我对Kelvin的代码进行了一些修改（感谢@kelvin！）我想澄清一下，我想要做的就是将特殊值将这些销售ID粘贴到我的“Tables”选项卡中，基于pre的位置格式化的表格。请参阅下面的新图片以及重新设置的代码。请注意我的“表格”选项卡中没有销售ID的公式（我的错误，我不清楚）

最后一点说明：我要解决的最后一件事就是扫描两个范围并将唯一对过滤成一个数组，使数组CFValues低于动态 - 如果您知道如何做得更好，请帮忙比我！

Option Explicit

Sub SortNCopy2TablesV2()

Dim CFValues As Variant

Dim r As Integer
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim CombStr As Variant
Const startRow As Long = 7 'kelvin added

CFValues = Array("P A", "P B", "P C", "P F", "M A", "SP A", "SP B", "SP C")


Set ws1 = Worksheets("Cashflow")
Set ws2 = Worksheets("Tables")

r = startRow 'kelvin changed

'kelvin added
Application.ScreenUpdating = False
On Error Resume Next
For i = LBound(CFValues) To UBound(CFValues)
    Worksheets.Add
    ActiveSheet.Name = CFValues(i)
    If Err.Number = 1004 Then
        Application.DisplayAlerts = False
        Worksheets(CFValues(i)).Cells.Clear
        ActiveSheet.Delete
        Application.DisplayAlerts = True
    End If
Next i
On Error GoTo 0

With ws1 'kelvin added

    Do Until .Range("C" & r).Value = ""

        CombStr = .Range("C" & r).Text + " " + .Range("D" & r).Text 'kelvin changed

        For i = LBound(CFValues) To UBound(CFValues)

            If StrComp(CombStr, CFValues(i), vbTextCompare) = 0 Then 'kelvin changed
                                    'kelvin added 1 lines of code:
                .Range("B" & r).Copy _
                        Worksheets(CFValues(i)).Range("B" & Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B")) + 1)

            End If
        Next i
        r = r + 1
    Loop
End With

'kelvin added
Dim nextRow As Long
Dim tempRow As Long
Dim numRows As Long

nextRow = 5

For i = LBound(CFValues) To UBound(CFValues)
    tempRow = Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B"))

    If tempRow > 0 Then

        numRows = Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B"))

        ws2.Range("B" & nextRow + 1).EntireRow.Resize(numRows).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        ws2.Range("C" & nextRow & ":" & "F" & nextRow + numRows).FillDown
        Worksheets(CFValues(i)).Range("B2").CurrentRegion.Copy ws2.Range("B" & nextRow + 1)
        ws2.Range("B" & nextRow + 2 + tempRow) = CFValues(i)
        nextRow = nextRow + tempRow + 5

    End If
Next i

Application.ScreenUpdating = True

End Sub

Answer 1

根据您的代码，第一个表的标题从单元格B6开始，第一行数据从B7开始。修改你的宏，我设法进行排序并将结果放在Tables表上。但是，我无法为您计算NPV，因为我不知道确切的公式。请找到代码：

 Option Explicit

    Sub SortNCopy2TablesV2()

    Dim CFValues As Variant
    'Dim InsertRow As Variant
    Dim R As Integer
    Dim i As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim CombStr As Variant
    Const startRow As Long = 7 'kelvin added

    CFValues = Array("P A", "P B", "P C", "P F", "M A", "SP A", "SP B", "SP C")
   ' InsertRow = Array(6, 11, 16, 21, 26, 31, 36, 41)

    Set ws1 = Worksheets("Cashflow")
    Set ws2 = Worksheets("Tables")

    R = startRow 'kelvin changed

    'kelvin added
    Application.ScreenUpdating = False
    On Error Resume Next
    For i = LBound(CFValues) To UBound(CFValues)
        Worksheets.Add
        ActiveSheet.Name = CFValues(i)
        If Err.Number = 1004 Then
            Application.DisplayAlerts = False
            Worksheets(CFValues(i)).Cells.Clear
            ActiveSheet.Delete
            Application.DisplayAlerts = True
        End If
    Next i
    On Error GoTo 0

    With ws1 'kelvin added
       'org: Do Until ws1.Range("C" & R).Value = ""
        Do Until .Range("C" & R).Value = ""

           'org:  CombStr = ws1.Range("C" & R).Text + "" + ws1.Range("D" & R).Text
            CombStr = .Range("C" & R).Text + " " + .Range("D" & R).Text 'kelvin changed

            For i = LBound(CFValues) To UBound(CFValues)
                'org: If StrComp(CombStr, CFValues(i), vbTextCompare) Then
                If StrComp(CombStr, CFValues(i), vbTextCompare) = 0 Then 'kelvin changed
                    'Return value of first insert row in InsertRow[] array -
                    ' i.e. if P A, then it should return row 6 for insertion, if P B, then row 11, etc.
                    'insert new row, copying and pasting the formulas down and copying the sales ID
                    'Insert Sales ID value into Table tab
                    'org: ActiveCell.Offset(1, 0).EntireRow.Copy
                    'org: ActiveCell.Offset(2, 0).EntireRow.Insert Shift:=xlDown
                    'org:  ActiveCell.Offset(2, 0).EntireRow.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
                    'org:  Application.CutCopyMode = False
                    'org:  ws1.Range("B" & R).Value = ws2.Range("B" & InsertRow(i) + 1).Value

                    'kelvin added 1 lines of code:
                    .Range("A" & R).EntireRow.Copy _
                            Worksheets(CFValues(i)).Range("A" & Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B")) + 1)

                    'decrement InsertRow[] array, so that the
                    'program always knows where to find the next tables for insertion
                'Else
                End If
            Next i
            R = R + 1
        Loop
    End With

    'kelvin added
    ws2.Cells.Clear
    Dim nextRow As Long
    Dim tempRow As Long
    nextRow = startRow
    For i = LBound(CFValues) To UBound(CFValues)
        tempRow = Application.WorksheetFunction.CountA(Worksheets(CFValues(i)).Range("B:B"))
        If tempRow > 0 Then
            ws1.Range("A" & startRow - 1).EntireRow.Copy ws2.Range("A" & nextRow - 1)
            Worksheets(CFValues(i)).Range("B2").CurrentRegion.Copy ws2.Range("B" & nextRow)
            ws2.Range("A" & nextRow + tempRow) = CFValues(i)
            nextRow = nextRow + tempRow + 5
        End If
    Next i
    Application.ScreenUpdating = True

End Sub

（糟糕......我无法发布图片。请找到输入和输出的粘贴文字） 样本输入：

销售ID S类B类平衡月率 1 P A 100 20 5 2 P A 200 25 4 3 P A 300 30 3 4 SP C 400 35 2 5 SP C 500 40 1 6 M C 600 45 2 7 M B 700 50 3 8 M B 800 55 4 9 P F 900 60 5 10 SP F 1000 55 6 11 M F 1100 50 7 12 M A 1200 45 8 13 Sp B 1300 40 9 14 Sp C 1400 35 10

示例输出：

Sale ID S Class B Class Balance Month   Rate
1   P   A   100 20  5
2   P   A   200 25  4
3   P   A   300 30  3

P A

Sale ID S Class B Class Balance Month   Rate
9   P   F   900 60  5

P F

Sale ID S Class B Class Balance Month   Rate
12  M   A   1200    45  8

M A

Sale ID S Class B Class Balance Month   Rate
13  Sp  B   1300    40  9

SP B

Sale ID S Class B Class Balance Month   Rate
4   SP  C   400 35  2
5   SP  C   500 40  1
14  Sp  C   1400    35  10

SP C

请评论。谢谢。

Answer 2

我在写这段代码时看到你收到了另一个答案，但是无论如何我都会发布它。下面的代码应该粘贴到Tables表的vba部分。然后，您应该在该工作表上创建一个按钮（在开发人员选项卡中）并将其分配给宏StartSortClick

此代码假定以下内容，并且必须根据不正确的内容进行相应更改。如果你在下面评论我的假设是错误的，我可以为你更新，或者你可以自己做。

1. CashFlow标签在第1行有标题，销售ID在A1，卖家类在B1等
2. 在表格选项卡中，您希望第一个表格从第10行开始，然后在A列中开始，以便第一个表格的销售ID在A10中写入。
3. 我没有输入价格和npv的公式，如果您愿意，请提供您的公式。
4. 字体也可以改变。只需要代码末尾的整个工作表（代码将在代码运行之前覆盖手动字体更改，以确保正确放置表格边框）。

我确信它本来可以做得更整齐，而且我觉得它可能很慢，有10000多行，但它可以满足您的要求。我现在看到，使用二维数组会更快。使用它的一个版本（因为我需要自己更好地使用数组，并且你的问题很有趣）

Public Sub StartSortClick()
If MsgBox("This will rebuild the Tables tab! Continue?", vbYesNo, "Rebuild Tables Tab?") Then
    SortNCopyTables
End If
End Sub

Private Sub SortNCopyTables()
Application.ScreenUpdating = False

Dim sheetCollection As Collection
Set sheetCollection = New Collection

Dim cashFlowSheet As Worksheet
Set cashFlowSheet = Worksheets("CashFlow")

Dim SaleIDRange, BalanceRange, MonthlyRange, RateRange As Range 'Change the letters and starting rows as necessary
Set SaleIDRange = cashFlowSheet.Range("A2:A" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set BalanceRange = cashFlowSheet.Range("D2:D" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set MonthlyRange = cashFlowSheet.Range("E2:E" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row) ' not used now but assume is used for npv / price calcs
Set RateRange = cashFlowSheet.Range("F2:F" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)

'loop through all rows, if encountering a new seller-bucket combo, create a new sheet, name it that seller-bucket combo and add it to the sheetCollection
Dim cRow As Long
cRow = 2 ' should be the location of first cashflow entry
Dim sellerBucketString As String
Dim tempSheet As Worksheet
Dim firstUnusedRow As Long
Do Until cashFlowSheet.Cells(cRow, 1) = "" ' here you should change the 1 to whatever column is your Sale ID column (mine are in A)
    sellerBucketString = cashFlowSheet.Cells(cRow, 2).Value + " & " + cashFlowSheet.Cells(cRow, 3).Value
    If Not InCollection(sheetCollection, sellerBucketString) Then
        'create new sheet and add to collection
        With ThisWorkbook
            Set tempSheet = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            tempSheet.Name = sellerBucketString
            sheetCollection.Add tempSheet, tempSheet.Name
        End With
    End If

    ' select worksheet and insert row at the bottom)
    Set tempSheet = sheetCollection.Item(sellerBucketString)
    firstUnusedRow = tempSheet.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).row
    tempSheet.Cells(firstUnusedRow, 1).Value = cashFlowSheet.Cells(cRow, 1).Value
    cRow = cRow + 1
Loop


'loop through sheets in the collection and create appropriate report tables in Tables sheet
Dim tablesSheet As Worksheet
Set tablesSheet = Worksheets("Tables")
'clear the tableSheet, just in case
tablesSheet.Rows(10 & ":" & tablesSheet.Rows.Count).Clear

Dim tRow As Long
tRow = 10 ' this is where I start to build my table
Dim row As Long
Dim tempSumRow As Range
Dim ws As Worksheet
For Each ws In sheetCollection
    Dim tableStartRow As Long
    tableStartRow = tRow + 1
    With tablesSheet
        .Cells(tRow, 1).Value = "Sale ID"
        .Cells(tRow, 1).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 2).Value = "NPV"
        .Cells(tRow, 2).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 3).Value = "Price"
        .Cells(tRow, 3).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 4).Value = "Balance"
        .Cells(tRow, 4).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 5).Value = "Rate"
        .Cells(tRow, 5).Font.Underline = xlUnderlineStyleSingleAccounting
        tRow = tRow + 1

        For row = 2 To ws.Cells.SpecialCells(xlCellTypeLastCell).row
            .Cells(tRow, 1).Value = ws.Cells(row, 1).Value
            '.Cells(tRow, 2).Value = ??? NPV formula?
            '.Cells(tRow, 3).Value = ??? price formula?
            .Cells(tRow, 4).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + BalanceRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
            .Cells(tRow, 4).NumberFormat = "$#,##0.00"
            .Cells(tRow, 5).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + RateRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
            .Cells(tRow, 5).NumberFormat = "0.0 %"
            tRow = tRow + 1
        Next row
        ' add summing row
        .Cells(tRow, 1).Value = ws.Name
        .Cells(tRow, 1).Font.Bold = True
        .Cells(tRow, 2).Formula = "=SUM(B" + CStr(tableStartRow) + ":B" + CStr(tRow - 1) + ")"
        .Cells(tRow, 3).Formula = "=AVERAGE(C" + CStr(tableStartRow) + ":C" + CStr(tRow - 1) + ")"
        .Cells(tRow, 4).Formula = "=SUM(D" + CStr(tableStartRow) + ":D" + CStr(tRow - 1) + ")"
        .Cells(tRow, 5).Formula = "=AVERAGE(E" + CStr(tableStartRow) + ":E" + CStr(tRow - 1) + ")"
        Set tempSumRow = tablesSheet.Range("A" + CStr(tRow) + ":E" + CStr(tRow))
        With tempSumRow.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With tempSumRow.Borders(xlEdgeBottom)
            .LineStyle = xlDouble
            .Weight = xlThick
        End With

        '.Cells(
        'create space for new table (this leaves one row of space, increase to 3 or more if you wish)
        tRow = tRow + 2
    End With
Next ws
tablesSheet.Cells.Font.Name = "Arial" ' change this to your appropriate font
DeleteAll
tablesSheet.Activate
Application.ScreenUpdating = True
End Sub
Private Function InCollection(col As Collection, sKey As String) As Boolean

Dim bTest As Boolean

On Error Resume Next

bTest = IsObject(col(sKey))
If (Err = 0) Then
    InCollection = True
Else
    Err.Clear
End If

End Function
Private Sub DeleteAll()
Dim i As Integer
i = Worksheets.Count
For x = i To 3 Step -1
    Application.DisplayAlerts = False
    Worksheets(x).Delete
    Application.DisplayAlerts = True
Next x
End Sub

编辑：

确定。 Redid代码使用数组在将单元格值写入表格表之前存储单元格值。它做得稍快，1分57秒对2分22对15,000行。这是替代代码。如果您想使用它，请改变按钮单击以调用此公式。请注意，此代码可能稍微不整洁，因为我现在需要注销stackExchange。

Private Sub SortNCopyTables2()
Application.ScreenUpdating = False

Dim saleIDs() As Variant
Dim sellerClass() As Variant
Dim bucketClass() As Variant



Dim cashFlowSheet As Worksheet
Set cashFlowSheet = Worksheets("CashFlow")

Dim lastSaleIDRow As Long
lastSaleIDRow = cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row

saleIDs = cashFlowSheet.Range("A2:A" & lastSaleIDRow).Value
sellerClass = cashFlowSheet.Range("B2:B" & lastSaleIDRow).Value
bucketClass = cashFlowSheet.Range("C2:C3" & lastSaleIDRow).Value

Dim classPairsArray() As Variant
Dim classPairs() As String
ReDim Preserve classPairs(0)
ReDim Preserve classPairsArray(0)
Dim size As Long
size = 0
Dim saleID As String

Dim tempArray() As String
For counter = 1 To UBound(saleIDs, 1)
    sellerBucketString = sellerClass(counter, 1) + " & " + bucketClass(counter, 1)

    If UBound(Filter(classPairs, sellerBucketString)) < 0 Then

        ReDim Preserve classPairs(size)

        classPairs(size) = sellerBucketString

        ReDim Preserve classPairsArray(size)

        ReDim Preserve tempArray(0)
        tempArray(0) = sellerBucketString

        classPairsArray(size) = tempArray

        size = size + 1
    End If

    Dim position As Long

    For i = 0 To UBound(classPairsArray)
        tempArray = classPairsArray(i)

        If sellerBucketString = tempArray(0) Then
            tempArray = classPairsArray(i)
            ReDim Preserve tempArray(UBound(tempArray) + 1)
            tempArray(UBound(tempArray)) = saleIDs(counter, 1)

            classPairsArray(i) = tempArray
            Exit For
        End If

    Next i

Next counter

'loop through array and write to worksheet
Dim tablesSheet As Worksheet
Set tablesSheet = Worksheets("Tables")
'clear the tableSheet, just in case
tablesSheet.Rows(10 & ":" & tablesSheet.Rows.Count).Clear

Dim SaleIDRange, BalanceRange, MonthlyRange, RateRange As Range 'Change the letters and starting rows as necessary
Set SaleIDRange = cashFlowSheet.Range("A2:A" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set BalanceRange = cashFlowSheet.Range("D2:D" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set MonthlyRange = cashFlowSheet.Range("E2:E" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row) ' not used now but assume is used for npv / price calcs
Set RateRange = cashFlowSheet.Range("F2:F" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)

Dim tRow As Long
tRow = 10 ' this is where I start to build my table
Dim row As Long
Dim tempSumRow As Range

For i = 0 To UBound(classPairsArray)
    Dim tableStartRow As Long
    tableStartRow = tRow + 1
    Dim tableSellerBucketGroup As String
    Dim tableArray() As String
    tableArray = classPairsArray(i)
    With tablesSheet
        .Cells(tRow, 1).Value = "Sale ID"
        .Cells(tRow, 1).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 2).Value = "NPV"
        .Cells(tRow, 2).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 3).Value = "Price"
        .Cells(tRow, 3).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 4).Value = "Balance"
        .Cells(tRow, 4).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 5).Value = "Rate"
        .Cells(tRow, 5).Font.Underline = xlUnderlineStyleSingleAccounting
        tRow = tRow + 1
        For j = 1 To UBound(tableArray)
            .Cells(tRow, 1).Value = tableArray(j)
            '.Cells(tRow, 2).Value = ??? NPV formula?
            '.Cells(tRow, 3).Value = ??? price formula?
            .Cells(tRow, 4).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + BalanceRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
            .Cells(tRow, 4).NumberFormat = "$#,##0.00"
            .Cells(tRow, 5).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + RateRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
            .Cells(tRow, 5).NumberFormat = "0.0 %"
            tRow = tRow + 1
        Next j
        .Cells(tRow, 1).Value = tableArray(0)
        .Cells(tRow, 1).Font.Bold = True
        .Cells(tRow, 2).Formula = "=SUM(B" + CStr(tableStartRow) + ":B" + CStr(tRow - 1) + ")"
        .Cells(tRow, 3).Formula = "=AVERAGE(C" + CStr(tableStartRow) + ":C" + CStr(tRow - 1) + ")"
        .Cells(tRow, 4).Formula = "=SUM(D" + CStr(tableStartRow) + ":D" + CStr(tRow - 1) + ")"
        .Cells(tRow, 5).Formula = "=AVERAGE(E" + CStr(tableStartRow) + ":E" + CStr(tRow - 1) + ")"
        Set tempSumRow = tablesSheet.Range("A" + CStr(tRow) + ":E" + CStr(tRow))
        With tempSumRow.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With tempSumRow.Borders(xlEdgeBottom)
            .LineStyle = xlDouble
            .Weight = xlThick
        End With
        tRow = tRow + 2
    End With
Next i
tablesSheet.Activate
Application.ScreenUpdating = True
End Sub

Answer 3

gudal编写了一个可行的代码来生成表格。请查看完整代码，对gudal代码和输入输出样本进行细微更改 代码：

Private Sub SortNCopyTables2()
Application.ScreenUpdating = False

Dim saleIDs() As Variant
Dim sellerClass() As Variant
Dim bucketClass() As Variant



Dim cashFlowSheet As Worksheet
Set cashFlowSheet = Worksheets("CashFlow")

Dim lastSaleIDRow As Long
lastSaleIDRow = cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row

saleIDs = cashFlowSheet.Range("A2:A" & lastSaleIDRow).Value
sellerClass = cashFlowSheet.Range("B2:B" & lastSaleIDRow).Value
bucketClass = cashFlowSheet.Range("C2:C3" & lastSaleIDRow).Value

Dim classPairsArray() As Variant
Dim classPairs() As String
ReDim Preserve classPairs(0)
ReDim Preserve classPairsArray(0)
Dim size As Long
size = 0
Dim saleID As String

Dim tempArray() As String
For counter = 1 To UBound(saleIDs, 1)
    sellerBucketString = sellerClass(counter, 1) + " & " + bucketClass(counter, 1)

    If UBound(Filter(classPairs, sellerBucketString)) < 0 Then

        ReDim Preserve classPairs(size)

        classPairs(size) = sellerBucketString

        ReDim Preserve classPairsArray(size)

        ReDim Preserve tempArray(0)
        tempArray(0) = sellerBucketString

        classPairsArray(size) = tempArray

        size = size + 1
    End If

    Dim position As Long

    For i = 0 To UBound(classPairsArray)
        tempArray = classPairsArray(i)

        If sellerBucketString = tempArray(0) Then
            tempArray = classPairsArray(i)
            ReDim Preserve tempArray(UBound(tempArray) + 1)
            tempArray(UBound(tempArray)) = saleIDs(counter, 1)

            classPairsArray(i) = tempArray
            Exit For
        End If

    Next i

Next counter

'loop through array and write to worksheet
Dim tablesSheet As Worksheet
Set tablesSheet = Worksheets("Tables")
'clear the tableSheet, just in case
'org: tablesSheet.Rows(10 & ":" & tablesSheet.Rows.Count).Clear
tablesSheet.Cells.Clear  'kelvin edited

Dim SaleIDRange, BalanceRange, MonthlyRange, RateRange As Range 'Change the letters and starting rows as necessary
Set SaleIDRange = cashFlowSheet.Range("A2:A" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set BalanceRange = cashFlowSheet.Range("D2:D" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)
Set MonthlyRange = cashFlowSheet.Range("E2:E" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row) ' not used now but assume is used for npv / price calcs
Set RateRange = cashFlowSheet.Range("F2:F" & cashFlowSheet.Cells.SpecialCells(xlCellTypeLastCell).row)

Dim tRow As Long
tRow = 10 ' this is where I start to build my table
Dim row As Long
Dim tempSumRow As Range

For i = 0 To UBound(classPairsArray)
    Dim tableStartRow As Long
    tableStartRow = tRow + 1
    Dim tableSellerBucketGroup As String
    Dim tableArray() As String
    tableArray = classPairsArray(i)
    With tablesSheet
        .Cells(tRow, 1).Value = "Sale ID"
        .Cells(tRow, 1).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 2).Value = "NPV"
        .Cells(tRow, 2).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 3).Value = "Price"
        .Cells(tRow, 3).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 4).Value = "Balance"
        .Cells(tRow, 4).Font.Underline = xlUnderlineStyleSingleAccounting
        .Cells(tRow, 5).Value = "Rate"
        .Cells(tRow, 5).Font.Underline = xlUnderlineStyleSingleAccounting
        tRow = tRow + 1
        For j = 1 To UBound(tableArray)
            .Cells(tRow, 1).Value = tableArray(j)
            '.Cells(tRow, 2).Value = ??? NPV formula?
            '.Cells(tRow, 3).Value = ??? price formula?
            'org: .Cells(tRow, 4).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + BalanceRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
            .Cells(tRow, 4).Formula = "=IFERROR(INDEX(" + cashFlowSheet.Name + "!" + BalanceRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0)),)"  'kelvin edited
            .Cells(tRow, 4).NumberFormat = "$  #,##0.00"  'kelvin edited
            'org: .Cells(tRow, 5).Formula = "=INDEX(" + cashFlowSheet.Name + "!" + RateRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0))"
            .Cells(tRow, 5).Formula = "=IFERROR(INDEX(" + cashFlowSheet.Name + "!" + RateRange.Address + ",MATCH(A" + CStr(tRow) + "," + cashFlowSheet.Name + "!" + SaleIDRange.Address + ",0)),)"   'kelvin edited
            .Cells(tRow, 5).NumberFormat = "0%"  'kelvin edited
            .Cells(tRow, 2).Formula = "=IFERROR(NPV(RC[3],RC[2]),)"  'kelvin added.
            .Cells(tRow, 2).NumberFormat = "$  #,##0.00"   'kelvin added.
            .Cells(tRow, 3).Formula = "=IFERROR(RC[-1]/RC[1],)"  'kelvin added.
            .Cells(tRow, 3).NumberFormat = "0%"   'kelvin added.

            tRow = tRow + 1
        Next j
        .Cells(tRow, 1).Value = tableArray(0)
        .Cells(tRow, 1).Font.Bold = True
        .Cells(tRow, 2).Formula = "=SUM(B" + CStr(tableStartRow) + ":B" + CStr(tRow - 1) + ")"
        'org: .Cells(tRow, 3).Formula = "=AVERAGE(C" + CStr(tableStartRow) + ":C" + CStr(tRow - 1) + ")"
         .Cells(tRow, 3).Formula = "=IFERROR(RC[-1]/RC[1],)"   'kelvin added.
         .Cells(tRow, 3).NumberFormat = "0%"    'kelvin added.
        .Cells(tRow, 4).Formula = "=SUM(D" + CStr(tableStartRow) + ":D" + CStr(tRow - 1) + ")"
        'org: .Cells(tRow, 5).Formula = "=AVERAGE(E" + CStr(tableStartRow) + ":E" + CStr(tRow - 1) + ")"
        Set tempSumRow = tablesSheet.Range("A" + CStr(tRow) + ":E" + CStr(tRow))
        With tempSumRow.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With tempSumRow.Borders(xlEdgeBottom)
            .LineStyle = xlDouble
            .Weight = xlThick
        End With
        tRow = tRow + 2
    End With
Next i
tablesSheet.Activate
Application.ScreenUpdating = True
End Sub

样本输入和样本输出：

感谢gudal。