Sub InsRows()
    Dim i As Long, j As Long, k As Long, m As Long, n As Long
    Dim maDt As Long, miDt As Long, a(), b(), z, q
    Application.ScreenUpdating = False
    Set z = CreateObject("Scripting.Dictionary")
    i = Cells(Rows.Count, 1).End(xlUp).Row
    a = Range("A3:P" & i).Value
    miDt = Application.Min(Range("H3:H" & i))
    maDt = Application.Max(Range("H3:H" & i))
    For i = 1 To UBound(a, 1): z(a(i, 2)) = i: Next
    ReDim b(1 To z.Count * (maDt - miDt + 1), 1 To UBound(a, 2))
    For Each q In z.Items
        For j = miDt To maDt
            k = k + 1
            For m = 1 To 7
                b(k, m) = a(q, m)
                b(k, 8) = j
                For i = 1 To UBound(a, 1)
                    If a(i, 8) = j Then
                        If a(i, 2) = b(k, 2) Then
                            For n = 9 To 16: b(k, n) = a(i, n): Next
                            Exit For
    End If: End If: Next: Next: Next: Next
    [A3].Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub