使用两个数组sorting表
请耐心等待，试图解释困境。 我想写一个macros，这将帮助我sorting下表：
并尝试使用这些预格式化表格将销售IDsorting到另一个工作表（在同一工作簿中）：
最终结果应该如下图所示我需要做的是填写销售ID和公式右侧的销售ID列计算或执行查找：
问题是我的团队已经手动填写表格或者使用sortingfunction的组合来手动填写表格。 问题是，当我们有超过10,000个销售ID并且没有自动化时，这可能是一个痛苦。 我试图编码这个来帮助我的团队没有得到我有限的vba知识的帮助 – 任何帮助表示赞赏：
编辑：我对开尔文的代码进行了一些修改（谢谢@ kelvin！），我想澄清的是，我想要做的就是将特殊值这些销售ID粘贴到我的“表”选项卡的基础上的预格式化表的位置。 请参阅下面的新图片以及重新提交的代码。 请注意我的“表格”选项卡中没有销售ID的公式（我的错误我不清楚）
最后一点：我试图解决的最后一件事情是扫描两个范围，并将唯一对筛选出来，使数组CFValues低于dynamic – 请帮助，如果你知道如何做到这一点比我更好！
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("PA", "PB", "PC", "PF", "MA", "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 gudal写了一个可行的代码来生成表格。 请查看完整的代码，对gudal代码和input输出样本进行小改动。
代码：
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
样本input和样本输出： 
感谢gudal。
根据你的代码，第一个表的头部从单元格B6开始，第一行数据从B7开始。 修改你的macros，我设法做sorting，并把结果放在表格上。 但是，我不能为你计算NPV，因为我不知道确切的公式。 请find代码：
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("PA", "PB", "PC", "PF", "MA", "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 - ' ie if PA, then it should return row 6 for insertion, if PB, 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
（糟糕…我无法发布图像，请查找input和输出的粘贴文本）示例input：
销售ID S类B类别余额月率1 PA 100 20 5 2 PA 200 25 4 3 PA 300 30 3 4 SP C 400 35 2 5 SP C 500 40 1 6 MC 600 45 2 7 MB 700 50 3 8 MB 800 55 4 9 PF 900 60 5 10 SP F 1000 55 6 11 MF 1100 50 7 12 MA 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 PA 100 20 5 2 PA 200 25 4 3 PA 300 30 3
PA
Sale ID S Class B Class Balance Month Rate 9 PF 900 60 5
PF
Sale ID S Class B Class Balance Month Rate 12 MA 1200 45 8
嘛
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
请给出意见。 谢谢。
当我写这段代码的时候，我看到你收到了另外一个答案，不过我仍然会把它贴出来。 下面的代码应粘贴到表格工作表的vba部分。 然后，您应该在该工作表上创build一个button（在开发人员选项卡中），并将其分配给macrosStartSortClick
这段代码假设如下，并且必须相应地更改不正确的内容。 如果你在下面评论我的假设是错误的，我可以为你更新，或者你可以自己做。
- CashFlow选项卡在第1行中具有标题，其中销售ID为A1，卖家类别为B1等
- 在表格选项卡中，您希望第一个表格从第10行开始，并在第A列，以便第一个表格的销售ID用A10写入。
- 我没有input价格和npv的公式，如果你希望我提供你的公式。
- 字体也是可变的。 就在代码末尾的整个工作表（在代码运行之前，代码将覆盖手动字体更改，以确保正确放置表格边框）。
我相信它本来可以做得更干净，而且我认为10000行以上的速度可能会很慢，但它确实符合你的要求。 使用二维数组会更快，我现在看到。 在一个版本的工作（因为我需要更好地使用arrays我自己，你的问题是有趣的工作）
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
编辑：
好。 在将数组写入表格表之前，使用数组来存储单元格值。 它做得稍微快一点，57分钟2分22秒15000行。 这是另一种代码。 如果你想使用它，改变button点击调用这个公式。 注意这个代码可能会有点乱，因为我现在需要注销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