Using two arrays to sort into tables - vba

Question

Please be patient as I try to explain the dilemma. I am trying to write a macro that will help me sort the following table:
and trying to sort by sales ID into another worksheet(within the same workbook) with these pre-formatted tables:
End result should look like below image where all I need to do is fill in the sales ID and the formulas to the right of the sales ID column calculate or perform lookups:
Problem is that my team has been filling the tables manually or using a combination of the sort function to fill in the tables manually. Problem is that this can be a pain when we have 10,000+ sales IDs and no automation. My attempt at coding this to help my team has not been helped by my limited vba knowledge - any assistance appreciated:
Edit: I made some modifications to Kelvin's code (thanks #kelvin!) and I want to clarify that all I want to do is paste special values those sales ID into my "Tables" tab based off of the positions of the pre-formatted table. See new image below as well as re-posed code. Note the formulas in my Tables tab without Sales IDs (my fault that I wasn't clear)
One last note: The last thing I am trying to solve to complete this is to scan two ranges and filter out the unique pairs into an array to make the array CFValues below dynamic - please help if you know how to do this better than me!
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

According to your codes, the header of the first table starts at cell B6 and the first row of data starts at B7. Modifying your macros, I manage to do the sorting and place the result on the Tables sheet. However, I can't calculate the NPV for you because I don't know the exact formula. Please find the codes:
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
(Oops... I can't post Image. Please find the pasted text of input and output)
Sample Input:
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
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
Sample Output:
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
Please comment. Thank you.

Answer 2

I saw you received an other answer while I wrote this code, but though I would post it anyway. The code below should be pasted to the vba part of the Tables sheet. You should then create a button on that sheet (in developer tab) and assign it to the macro StartSortClick
This code assumes the following, and it must be changed accordingly for what is not correct. If you comment below where my assumptions are wrong, I can update it for you, or you can do it yourself.
CashFlow tab has headings in row 1, with Sale ID in A1, Seller Class in B1, etc
In the tables tab, you want the first table to start at row 10, and in column A, so that Sale ID of the first table is written in A10.
I have not entered formulas for price and npv, provide your formulas if you wish me to.
Font is changable too. Just to it for the entire sheet at the end of the code (code will overwrite manual font change before code is run, to ensure table borders are placed properly).
I am sure it could have been done neater, and I think it could be slow with 10000+ rows but it does what you ask. Using 2-dimensional arrays would be quicker, I see now. Working on a version of that (because I need to get better at using arrays myself, and your problem was fun working on)
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
EDIT:
Ok. Redid code using arrays to store cell values prior to writing them to the tables sheet. It did slightly faster, 1 min 57 vs 2 min 22 for 15,000 rows. Here is the alternative code. Alter the button click to call this formula instead if you wish to use it. Note this code might be a bit more untidy, as I need to log off stackExchange now.
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 has written a workable code to generate the tables. Please find the complete code with small changes to gudal's code and the samples of input and output.
The code:
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
Sample input and sample output:
Thanks to gudal.