VBA / copy & insert rows with specific columns depending on cell value

Hello,

I was trying to figure out how to do the following:

For each row:
1. Scan for the integer value found under column "I" on "Worksheet" (titled rows to duplicate).
2. Copy that row (with specific columns - highlighted in yellow)
3. Go to other sheet, insert rows to match the integer value
4. Paste copied row to inserted rows
5. Apply all borders
Repeat for next row

Here's the code for the attached worksheet. I was trying to get it to work but it is a bit clunky. Can anyone help out?

Sub InsertWorksheetRows()
   
    Dim wsCopyFrom As Worksheet
    Dim wsCopyTo As Worksheet
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lastrow_fws As Long
    Dim N_of_rows As Long
    Dim currentRow As Integer
    Dim i As Integer
    Dim currentNewSheetRow As Integer: currentNewSheetRow = 1
    Set wsCopyFrom = Worksheets("Worksheet")
    Set wsCopyTo = Worksheets("Testing_grounds")
    
wsCopyFrom.Activate
    
Firstrow = Application.WorksheetFunction.Match(("Order"), wsCopyFrom.Range("A:A"), 0)
Lastrow = Application.WorksheetFunction.Match(("Total"), wsCopyFrom.Range("G:G"), 0)
N_of_rows = Range(Cells(Firstrow, 1), Cells(Lastrow, 1)).Rows.Count

For currentRow = 3 To N_of_rows 'The last row of your data
  
    Dim timesToDuplicate As Integer
    timesToDuplicate = CInt(wsCopyFrom.Range("I" & currentRow).Value)

For i = 1 To timesToDuplicate
    
    wsCopyTo.Activate
    Lastrow_fws = Application.WorksheetFunction.Match(("Total"), Range("AA:AA"), 0) - 1 + 1
    wsCopyTo.Cells(Lastrow, 1).EntireRow.Insert
    
    'Row fill color
     wsCopyTo.Cells(ActiveCell.Row, 1).EntireRow.Interior.ColorIndex = 0
  
     wsCopyTo.Range("B" & currentNewSheetRow + 2).Value = wsCopyFrom.Range("B" & currentRow).Value
     wsCopyTo.Range("C" & currentNewSheetRow + 2).Value = wsCopyFrom.Range("C" & currentRow).Value
     wsCopyTo.Range("D" & currentNewSheetRow + 2).Value = wsCopyFrom.Range("D" & currentRow).Value
     wsCopyTo.Range("G" & currentNewSheetRow + 2).Value = wsCopyFrom.Range("E" & currentRow).Value
     wsCopyTo.Range("H" & currentNewSheetRow + 2).Value = wsCopyFrom.Range("F" & currentRow).Value
     
     currentNewSheetRow = currentNewSheetRow + 1
    
    Next i

Next currentRow
 
End Sub

Result in Sheet Test

Sub test()
Dim lr As Long, x As Long
Application.ScreenUpdating = False
With Sheets("Worksheet")
    .Columns("E:F").EntireColumn.Hidden = True
    lr = .Range("A" & Rows.Count).End(xlUp).Row + 1
    .Range("A1", "H2").SpecialCells(12).Copy Sheets("Test").Range("A1")
    For x = 3 To lr
        If .Range("I" & x).Value > 0 Then
            .Range("A" & x, "H" & x).SpecialCells(12).Copy Sheets("Test").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(.Range("I" & x).Value)
        End If
    Next
    .Range("A" & lr, "H" & lr).SpecialCells(12).Copy Sheets("Test").Range("A" & Rows.Count).End(xlUp).Offset(1)
    .Columns("E:F").EntireColumn.Hidden = False
End With
With Sheets("Test")
    .Rows.AutoFit
    .Columns.AutoFit
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    For x = 3 To lr
        .Range("A" & x) = x - 2
    Next
End With
End Sub

Kind regards
Leo

That worked great, thanks a lot for you time.