Copy and Insert Row Based on Cell Time Value

Question

My main problem is that I am trying to add a row directly beneath another row based on the time value of that row. Here's an example of what I'm trying to do:

column F ========> new column F

2                            1

                             2

2                            1

                             2

1                            1

1                            1

2                            1

                             2

To better explain, if the value in the first column F is a 2, that represents a time value that is greater than 0:59:00 and another row is added beneath it. If it is a 1, then it represents a time value that is equal to or less than 0:59:00 and no row gets added.

I have multiple coding attempts at fixing this, and this first one is by someone more well-versed in VBA than I and includes some of his comments:

Public Sub ExpandRecords()
Dim i As Long, _
    j As Long, _
    LR As Long
'set variable types
LR = Range("A" & Rows.Count).End(xlUp).Row
'setting variable LR as number of rows with data
Application.ScreenUpdating = False
Columns("F:F").NumberFormat = "hh:mm:ss"
'sets number format in column b to text
For i = LR To 1 Step -1
'Executes following code from last row with data to row 1 working backwards
    'If CLng(Left(Range("F" & i).Value, Len(Range("F" & i).Value) - 6)) > 0 Then
    If CLng(Hour(Range("F" & i))) > 0 Then
    'If the hour value in column F is greater than 1, then...
        With Range("F" & i)
        'starting with column F, loop through these statements...
            '.Offset(1, 0).Resize(CLng(Left(Range("F" & i).Value, Len(Range("F" & i).Value) - 6)) - 1, 1).EntireRow.Insert Shift:=xlDown
            .Offset(1, 0).Resize(CLng(Hour(Range("F" & i))).Value, Len(Range("F" & i).Value) - 1, 1).EntireRow.Insert Shift:=xlDown
            'return the value of column F's hour value, change the range to insert the number of rows below based on hour value
            '.Resize(CLng(Left(Range("F" & i).Value, Len(Range("F" & i).Value) - 6)), 1).EntireRow.Value = Range("A" & i).EntireRow.Value
            .Resize(Hour(Range("F" & i)), 1).EntireRow.Value = Range("A" & i).EntireRow.Value
            'Get value of row to be copied
            'For j = 0 To CLng(Left(Range("F" & i).Value, Len(Range("F" & i).Value) - 6))
            For j = 0 To Hour(Range("F" & i))
                Range("H" & i).Offset(j - 1, 0).Value = Application.Text(j, "0")
            Next j
        End With
    Else
        Range("H" & i).Value = Application.Text(1, "0")
    End If
Next i
Application.ScreenUpdating = True
End Sub

Here is a similar question from a previous user

Any help would be greatly appreciated.

Answer 1

Use this instead:

Public Sub ExpandRecords()

    Dim i As Long, s As String
    Const COL = "F"

    For i = 1 To Cells(Rows.Count, COL).End(xlUp).Row
        If Cells(i, COL) = 2 Then s = s & "," & Cells(i, COL).Address
    Next
    If Len(s) Then
        Range(Mid$(s, 2)).EntireRow.Insert
        For i = 1 To Cells(Rows.Count, COL).End(xlUp).Row
            If Cells(i, COL) = vbNullString Then Cells(i, COL) = 1
        Next
    End If

End Sub