Stop Inserting Entire Row, Only Insert Range

This is a very simply problem that I do not know how to fix.

Right now, the code below is inserting an entire row when it pastes the values in I only want the values to be inserted in Range (A:AJ).

The code seems to work great, that is the only problem. Please help.

I gratefully appreciated it.

Sub Macro1()
Set compro = Sheets("Sheet1")
cpqr = 1


For Each sh In Worksheets          'Cycle through all the sheets in the workbook

        'Determine whether this is a project worksheet
    If sh.Name = "Product1" Or sh.Name = "Product2" Then
        pr = 1                                                              'Keep track of which row on the project worksheet
        With sh
            Do Until pr > .Cells(1, 1).SpecialCells(xlLastCell).Row   'Stop when you get to the last row
            
        'Determine which quarter to paste into
                If .Cells(pr, 1) = "Current" Or .Cells(pr, 1) = "90 Days" Or .Cells(pr, 1) = "180 Days" Then
                    qtr = .Cells(pr, 1)
                    pr = pr + 1
    
        'Find the next empty row in the right quarter on the combined sheet
                    cpqr = compro.Cells.Find(qtr, compro.Range(compro.Cells(cpqr, 1), compro.Cells(cpqr, 1))).Row + 2
                    Do While compro.Cells(cpqr, 1) <> ""
                        cpqr = cpqr + 1
                    Loop
                End If
                
        'If this row on the project sheet has data, copy it to the combined sheet
                If .Cells(pr, 1) <> "" Then
                    compro.Range(compro.Cells(cpqr, 1), compro.Cells(cpqr, 1)).EntireRow.Insert
                    .Range(.Cells(pr, 3), .Cells(pr, 35)).Copy
                    compro.Range(compro.Cells(cpqr, 3), compro.Cells(cpqr, 35)).PasteSpecial Paste:=xlPasteValues
                    cpqr = cpqr + 1
                End If
                pr = pr + 1
            Loop
        End With
    End If
Next

End Sub