Macro til at kopier linjer baseret på hvad der står i en kolonne.

Mon ikke noget i denne retning kan bruges? Højreklik på Pakkelistens faneblad og læg det ind under koder

Sub flyt()
Dim LastRow, Rk, x As Long
LastRow = Worksheets("Pakket Oversigt").UsedRange.Rows.Count
Rk = Worksheets("Pakkelisten").UsedRange.Rows.Count
For x = 2 To Rk
If Cells(x, 10) = "Pakket" Then
Rows(x).EntireRow.Copy Destination:=Worksheets("Pakket oversigt").Cells(LastRow + 1, 1)
LastRow = LastRow + 1
End If
Next
End Sub

Hej Jens, den fungere tildeles.

Den tager dog ikke dem der er pakket. Men kun dem som ikke står der. Se vedhæftet billeder. Den tager dog samme antal som der står "Pakket" ved. Du kan se de to billeder i sharepointet. Heraf kan du sammenligne de 2 ordre nr. med hinanden.

https://stansomatic-my.sharepoint.com/:f:/g/personal/cba_stansomatic_dk/Eu9-JrUGiEZOnIL9-Zrpkd4BNiVNmQ8UsxTOOiR6kZKK1A?e=dVwahC

Jeg har rettet lidt i makroen, så den først sletter den oprindelige liste, før den laver en ny. Håber det er nok til at fjerne den fejl du har - og som jeg i øvrigt ikke kan se hvordan er opstået, da du har oploaded billeder i stedet for selve excelarket

Sub flyt()
Dim LastRow, Rk, x As Long
Worksheets("Pakket Oversigt").Range("A3:J1000").ClearContents
LastRow = 2
Rk = Worksheets("Pakkelisten").UsedRange.Rows.Count
For x = 3 To Rk
If Cells(x, 10) = "Pakket" Then
Rows(x).EntireRow.Copy Destination:=Worksheets("Pakket oversigt").Cells(LastRow + 1, 1)
LastRow = LastRow + 1
End If
Next
End Sub

Problemet var at makroen kopierer formler i stedet for værdier. Denne makro skulle kunne klare det:

Sub flyt()
Dim LastRow, Rk, x As Long
Worksheets("Pakket Oversigt").Range("A3:J1000").ClearContents
LastRow = 2
Rk = Worksheets("Pakkelisten").UsedRange.Rows.Count
For x = 3 To Rk
If Worksheets("Pakkelisten").Cells(x, 10) = "Pakket" Then
Worksheets("Pakkelisten").Range(Cells(x, 1), Cells(x, 10)).Copy
Worksheets("Pakket Oversigt").Cells(LastRow + 1, 1).PasteSpecial xlPasteValues
LastRow = LastRow + 1
End If
Next
End Sub

Og hvis du vil have den til at slette linjerne på "Pakkelisten" efter flytning, kan du bruge:

Sub flyt()
Dim LastRow, Rk, x As Long
LastRow = Worksheets("Pakket Oversigt").UsedRange.Rows.Count
Rk = Worksheets("Pakkelisten").UsedRange.Rows.Count
For x = Rk To 3 Step -1
If Worksheets("Pakkelisten").Cells(x, 10) = "Pakket" Then
Worksheets("Pakkelisten").Range(Cells(x, 1), Cells(x, 10)).Copy
Worksheets("Pakket Oversigt").Cells(LastRow + 1, 1).PasteSpecial xlPasteValues
Worksheets("Pakkelisten").Cells(x, 1).EntireRow.Delete
LastRow = LastRow + 1
End If
Next
End Sub

Sub flyt()
Dim LastRow, Rk, x As Long
'Worksheets("Pakket Oversigt").Range("A3:J1000").ClearContents
LastRow = Worksheets("Pakket Oversigt").UsedRange.Rows.Count
Rk = Worksheets("Pakkelisten").UsedRange.Rows.Count
For x = Rk To 3 Step -1
If Worksheets("Pakkelisten").Cells(x, 10) = "Pakket" Then
Worksheets("Pakkelisten").Range(Cells(x, 1), Cells(x, 10)).Copy
Worksheets("Pakket Oversigt").Cells(LastRow + 1, 1).PasteSpecial xlPasteValues
LastRow = LastRow + 1
End If
Next
Worksheets("Pakkelisten").Range("J3:J100").ClearContents
End Sub