根据单元格时间值复制和插入行

Question

我的主要问题是，我试图根据该行的时间值直接在另一行下面添加一行。下面是我要做的一个例子:

column F ========> new column F
2                            1
                             2
2                            1
                             2
1                            1
1                            1
2                            1
                             2

为了更好地解释，如果第一列F中的值为2，则表示时间值大于0:59:00，并且在其下方添加另一行。如果它是1，那么它表示一个等于或小于0:59:00的时间值，并且没有添加任何行。

我有多个编码尝试来修复这个问题，第一个是由比我更精通VBA的人编写的，其中包括他的一些评论:

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

这是前一个用户提出的类似问题

任何帮助都将非常感激。

Answer 1

用这个代替:

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