Sub copyRows()
    Dim lr&, lc&, i&, j&, r&, temp$
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    
    r = 2
    With sh1
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        lc = .Cells(1, Columns.Count).End(xlToLeft).Column
        sh2.Cells(2, 1).Resize(sh2.Cells(Rows.Count, 1).End(xlUp).Row, lc).ClearContents
        For i = 2 To lr
            For j = 1 To .Cells(i, "g")
                sh2.Cells(r, 1).NumberFormat = "@"
                .Cells(i, 1).Resize(, 7).Copy sh2.Cells(r, 1)
                If j = 1 Then
                    .Cells(i, 8).Resize(, lc - 7).Copy sh2.Cells(r, 10)
                Else
                    temp = Format(CDate(Right(sh2.Cells(r - 1, 3), 5)) + 1 / 24 / 60, "hh:mm")
                    sh2.Cells(r, 3) = Mid(sh2.Cells(r - 1, 3), 1, 20) & temp
                    sh2.Cells(r, 2) = sh2.Cells(r - 1, 2) + 1
                End If
                sh2.Cells(r, 8) = j
                With CreateObject("VBScript.RegExp")
                    .Pattern = "\d+"
                    Set objMatches = .Execute(sh1.Cells(i, 8))
                    If objMatches.Count Then
                        sh2.Cells(r, 9) = CInt(objMatches(0))
                    Else
                        sh2.Cells(r, 9) = 0
                    End If
                End With
                r = r + 1
            Next j
        Next i
    End With
End Sub