Add/Delete Rows based on cell value - excel

Question

so I have an excel table with 2 columns: Times and Count, and 3 Rows: 1:00, 2:00 and 3:00 pm. I want functionality where when the user changes the count value for any of the rows, the count value minus 1 row should be added underneath. So for example for 1:00 pm below, when the user enters '4', it should add three rows below that row for a total of 4 rows. If the user changes the count to '2' it should remove 2 rows so that there are 2 total rows. This is what I have so far:
Times Count
1:00pm 4
2:00pm 0
3:00pm 0
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("C5:C100")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
'Save Workbook before so that original document will be saved
ActiveWorkbook.Save
Dim List As Long
Dim i As Long
Dim x As Long
Dim ExCnt As Variant
Dim aVal As Integer
'Find how many rows contain data
List = Range("B" & Rows.Count).End(xlUp).Row
For i = List To 2 Step -1
'Store exception value into variable
ExCnt = Range("C" & i).Value
With Range("C" & i)
'Insert rows unless text says Exception Count
If .Value > 1 And .Value <> "Exception Count" Then
.EntireRow.Copy
Application.EnableEvents = False
.Offset(1).EntireRow.Resize(.Value - 1).Insert
End If
CleanExit:
End With
Next i
Application.EnableEvents = True
End If
End Sub
This code adds the right amount of rows for each row but if the user changes the count value, the effect will compound for the existing rows.

Answer 1

I hope you appreciate how intricate this can actually be. :-)
Try this solution ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strKey As String, lngCount As Long, lngOffset As Long
Dim i As Long, rngNewRows As Range, lngTopRow As Long, lngBottomRow As Long
Dim bInBetween As Boolean
' Anymore than 10 cells and we'll skip this process.
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 2 Then
On Error Resume Next
Err.Clear
lngCount = Target.Value
On Error GoTo 0
If Err.Description = "" Then
If lngCount = 0 Then lngCount = 1
If lngCount > 0 Then
' Get the time value.
strKey = Target.Offset(0, -1).Text
bInBetween = False
' Check to make sure that the user isn't entering a value in between an already exploded set of rows.
If Target.Row > 1 Then
If Target.Offset(-1, -1).Text = strKey Then bInBetween = True
End If
If Not bInBetween Then
lngOffset = 0
' Now check each column below and delete or add rows depending on the count.
Do While True
lngOffset = lngOffset + 1
If Target.Offset(lngOffset, -1).Text <> strKey Then Exit Do
Loop
Application.EnableEvents = False
If lngOffset < lngCount Then
' We need to add rows.
Set rngNewRows = Target.Worksheet.Rows(Target.Offset(lngOffset, 0).Row & ":" & Target.Offset(lngOffset, 0).Offset(lngCount - lngOffset - 1, 0).Row)
lngTopRow = rngNewRows.Cells(1, 1).Row
lngBottomRow = rngNewRows.Cells(rngNewRows.Rows.Count, 1).Row
rngNewRows.Insert
For i = lngTopRow To lngBottomRow
Target.Worksheet.Cells(i, Target.Column - 1) = Target.Offset(0, -1).Value
Next
Else
If lngOffset <> lngCount Then
' We're over the count, determine the rows to delete.
Target.Worksheet.Rows(Target.Offset(lngCount, 0).Row & ":" & Target.Offset(lngOffset - 1, 0).Row).Delete
Else
' We have 1 row and that's all that's been asked for.
End If
End If
Application.EnableEvents = True
End If
End If
End If
End If
End Sub
... you clearly have some other rules that need to be applied but this should get you going. Check out the image below to see it in action.
A few points ...
It tries to cater for individuals entering values in column B within the exploded range and if they do that, it won't react to the value. Not sure if that's a requirement but I assumed it was.
0 will be treated as 1, so both 1, 0 and cleared will result in the resetting of the line.
Deletions happen at the bottom. So if the number goes from 10 to 3, it will delete the last set of rows to bring it back to 3.
It will only react to 1 cell at a time being changed. It reduced the complexity of the solution.
Outside of that, you're on your own. :-)