Insert rows, repetative copy and paste - slow macro

[pnnaik]

Dear All,

I have written code with the help of some of the previous post on this site.

I have data sheet. I am to arrange this data sheet to upload it.


To arrange data sheet I am to insert some numbers of rows after certain number of rows.

After that some copy operation is there.

Code run as desired by me but is SLOW.

Kindly suggest modification to run it faster. Kindly note I do not know much about VBA coding.

Code

Sub Test()
Dim intCOLUMN_TO_WORK_IN As Integer
Dim lngROW_TO_STOP_AT As Long
Dim LRow As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Dim Width As Double
Dim Height As Double
Dim Thickness As Double
Dim rng As Range

Width = InputBox("Enter Width: ")
Height = InputBox("Enter Height: ")
Thickness = InputBox("Enter Thickness: ")

Set ws1 = Sheets("DATA")
Set ws2 = Sheets("UPLOAD")
Set rng = ws1.Range(Cells(2, 1), Cells(2, 10).End(xlDown))

  
rng.Sort Key1:=Cells(2, 2), Order1:=xlAscending, DataOption1:=xlSortNormal

On Error GoTo Handler:
Application.ScreenUpdating = False

Set ws1 = ActiveSheet
intCOLUMN_TO_WORK_IN = 2 'A
lngROW_TO_STOP_AT = 5 'header row, if needed

With ws1
    LRow = .Cells(Rows.Count, 2).End(xlUp).Row
    For i = LRow To lngROW_TO_STOP_AT Step -4
        For j = 1 To 7
            .Cells(i + 1, intCOLUMN_TO_WORK_IN).EntireRow.Insert shift:=xlDown
        Next j
    Next i
  LRow = .Cells(Rows.Count, 2).End(xlUp).Row
  
  For i = 1 To LRow Step 11
    .Range("a1:j1").Copy .Range("a" & i)
    .Range("k" & i).Value = "Width"
    .Range("L" & i).Value = "Height"
    .Range("M" & i).Value = "Thickness"
    .Range("K2:K5").Value = Width
    .Range("L2:L5").Value = Height
    .Range("M2:M5").Value = Thickness
  Next i

  For i = 13 To LRow Step 11
    .Range("a2:a5").Copy .Range("a" & i)
    .Range("K2:M5").Copy .Range("K" & i)
  Next i
    .Range("A1:M" & LRow).Copy: ws2.Range("B10").PasteSpecial xlPasteValues
End With
My_Exit_Sub:
Application.ScreenUpdating = True
Exit Sub
Handler:
MsgBox "Error: " & Err.Number & ": " & Err.Description
Resume My_Exit_Sub:
End Sub

Regards,

PN