OK, I got it to work by creating another loop, but I am not sure if
this is the most perficient way to it. *If anyone knows how to
recreate the code to be more perficient please let me know. *The
following is my new code:

Sub Copy_RowsByCriteria()
Dim x As String
Dim nDataRange As Range
Dim InsQuan As Long
Range("A2").Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do While ActiveCell.Value < ""
* InsQuan = 0
* If x < "" Then
* * Do While ActiveCell.Offset(0, 9).Value = x
* * * ActiveCell.Offset(1, 0).Select
* * Loop
* * *If Not ActiveCell.Value < "" Then
* * * Application.ScreenUpdating = True
* * * Application.Calculation = xlCalculationAutomatic
* * * Range("A1").Select
* * * MsgBox "Finished! "
* * * Exit Sub
* * *Else
* * * x = ActiveCell.Value
* * *End If
* Else
* * x = ActiveCell.Value
* End If
* Sheets("Sheet1").Select
* Range("J1").Select
* Do While ActiveCell.Value < ""
* * If ActiveCell.Value = x Then
* * * InsQuan = InsQuan + 1
* * End If
* * *ActiveCell.Offset(1, 0).Select
* Loop
* Sheets("Sheet4").Select
* ActiveCell.EntireRow.Offset(1, 0).Range("A1:A" & InsQuan).Select
* * * Selection.Insert Shift:=xlDown
* Sheets("Sheet1").Select
* Set nDataRange = Nothing
* Range("J1").Select
* Do While ActiveCell.Value < ""
* *If ActiveCell.Value = x Then
* * *If nDataRange Is Nothing Then
* * * *Set nDataRange = ActiveCell
* * *Else
* * * *Set nDataRange = Union(nDataRange, ActiveCell)
* * *End If
* *End If
* *ActiveCell.Offset(1, 0).Select
* *Loop
* *If nDataRange Is Nothing Then
* * *MsgBox "No cells found! "
* *Else
* * *nDataRange.EntireRow.Copy

* * *Sheets("Sheet4").Select
* * *Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone,
SkipBlanks:= _
* * * * * False, Transpose:=False
* * 'ActiveCell.Offset(1, 0).Select
* *End If
* *ActiveCell.Offset(1, 0).Select
*Loop

End Sub- Skjul tekst i anførselstegn -

- Vis tekst i anførselstegn -

Hi again

Try this code. It should run faster as it is referring to cells rather
than selecting. I have also moved around parts of your code and
deleted som if-then sentences...

I think it will meet your needs ;-)

Sub Copy_RowsByCriteria()
Dim x As String
Dim nDataRange As Range
Dim InsQuan As Long
Dim tCell As Range
Dim dCell As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Sheet4").Select
Set tCell = Range("A2")
x = tCell.Value
Do While tCell.Value < ""
InsQuan = 0
Do While tCell.Offset(1, 9).Value = x
Set tCell = tCell.Offset(1, 0)
Loop
Sheets("Sheet1").Select
Set dCell = Range("J1")
Do While dCell.Value < ""
If dCell.Value = x Then InsQuan = InsQuan + 1
Set dCell = dCell.Offset(1, 0)
Loop
Set dCell = Range("J1")
Do While dCell.Value < ""
If dCell.Value = x Then
If nDataRange Is Nothing Then
Set nDataRange = dCell
Else
Set nDataRange = Union(nDataRange, dCell)
End If
End If
Set dCell = dCell.Offset(1, 0)
Loop
If nDataRange Is Nothing Then
MsgBox ("No cells found! ")
Else
Sheets("Sheet4").Select
tCell.Offset(1, 0).Range("A1:A" & InsQuan +
xOff).EntireRow.Insert Shift:=xlDown
nDataRange.EntireRow.Copy
tCell.Offset(1, 0).PasteSpecial Paste:=xlPasteAll,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Set tCell = tCell.Offset(InsQuan + xOff + 1, 0)
x = tCell.Value
Set nDataRange = Nothing
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("A1").Select
MsgBox ("Finished! ")
End Sub

Regards,

Per