I have a .csv file that needs to be built semi regularly that has a parent prize with a total value and subprizes under it that equal the parent prize amount based on a breakdown table for each value. I’ve managed to get to the point where the new rows for subprizes are added based on the number of subprizes needed. I’m having trouble figuring out how to fill those rows with the data I need based on the breakdown. I currently have the breakdown values in column F under Description but I’m not sure if this is the best way to get VBA to recognize which subprizes need to be added.
Example of Parent Prize List:
Table Breakdown of Values:
Current Formula to pull out breakdowns (Column L):
It’s really just to make it easier to read since adding the subprizes is a manual process.
=TRIM(IF(ISBLANK(B2),"",$B$1&"x"&B2)&" "&IF(ISBLANK(C2),"",$C$1&"x"&C2)&" "&IF(ISBLANK(D2),"",$D$1&"x"&D2)&" "&IF(ISBLANK(E2),"",$E$1&"x"&E2)&" "&IF(ISBLANK(F2),"",$F$1&"x"&F2)&" "&IF(ISBLANK(G2),"",$G$1&"x"&G2)&" "&IF(ISBLANK(H2),"",$H$1&"x"&H2)&" "&IF(ISBLANK(I2),"",$I$1&"x"&I2)&" "&IF(ISBLANK(J2),"",$J$1&"x"&J2))
Subprizes that need to be added to new rows:
Current VBA Code to add the correct number of rows:
Sub InsertRowsIf()
Dim lr As Long, R As Range, i As Long
lr = Range("G" & Rows.Count).End(xlUp).Row
Set R = Range("G1", "G" & lr)
Application.ScreenUpdating = False
For i = R.Rows.Count To 1 Step -1
If IsNumeric(R.Cells(i, 1).Value) And Not IsEmpty(R.Cells(i, 1)) Then
R.Cells(i, 1).Offset(1, 0).Resize(R.Cells(i, 1).Value).EntireRow.Insert
End If
Next i
Application.ScreenUpdating = True
End Sub
What Final Product Should Look Like:
[
So basically, once the rows are added, I need it to see that $35 needs to have 1 row with the $15 subprize and 1 with $20. Or $40 needs to have 2 rows of $20 and so on. Any assistance with this would be amazing. If I figure out how to add the Excel File, I’ll make sure that’s in here as well.
I’m still very new to VBA but have some experience with functions so I haven’t been able to find anything on how to go about solving this.
HappyPanda is a new contributor to this site. Take care in asking for clarification, commenting, and answering.
Check out our Code of Conduct.
2
Paste code into a blank workbook to run as a demo.
Sub InsertRows()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With dict
.Add 30, Array(20, 10)
.Add 35, Array(20, 15)
.Add 40, Array(20, 20)
.Add 45, Array(25, 20)
.Add 55, Array(50, 5)
.Add 60, Array(50, 10)
.Add 65, Array(50, 15)
End With
Dim ws As Worksheet, ar, prize As Long
Dim lastrow As Long, r As Long, n As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
' set up test data
.Cells.Clear
For r = 2 To 11
.Cells(r, "E") = (r - 1) * 5
Next
' get last row
lastrow = .Cells(.Rows.Count, "E").End(xlUp).Row
' scan up the sheet
For r = lastrow To 2 Step -1
prize = .Cells(r, "E")
.Cells(r, 1) = "$" & prize & " PRIZE"
' does this value need multiple lines
If dict.exists(prize) Then
ar = dict(prize)
Else
ar = Array(prize)
End If
' insert rows
For i = 0 To UBound(ar)
.Rows(r + 1).Insert
.Cells(r + 1, 1) = "$" & ar(i) & " PRIZE"
n = n + 1
Next
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub