Har et stort ark

Noget i denne stil vil kunne klare det:

Sub Flyt()
Dim LastRow, x, y As Long
y = 9
LastRow = Range("C:C").SpecialCells(xlCellTypeLastCell).Row
For x = 6 To LastRow
If Application.WorksheetFunction.CountIf(Worksheets("Ark2").Range("B:B"), Cells(x, 3)) = 0 Then
Cells(x, 3).Copy Destination:=Worksheets("Ark2").Cells(y, 2)
y = y + 1
End If
Next
End Sub

virker næsten

Men næste gang jeg trykker på knappen er der måske halvt så mange data
Kan man ikke slette kolonne I Ark 2 inden man henter data over

Jeg har prøvet at spille sammen men virker ikke

Ups den kører ikke

Prøvede lige at teste på original data og ikke bare 12 tastede værdier

Den kører endnu og det er 10 min siswn jeg satte den i gang.

Som om den bare kører uendeligt

Jeg har rettet makroen, så den starter med at slette det der står i Ark2 Kolonne B og indsat en instruktion for at stoppe mellemregningerne. Det skulle gøre den meget hurtigere.

Sub Flyt()
Dim LastRow, x, y As Long
Application.Calculation = xlManual
Worksheets("Ark2").Range("B9:B1000").ClearContents
y = 9
LastRow = Range("C:C").SpecialCells(xlCellTypeLastCell).Row
For x = 6 To LastRow
If Application.WorksheetFunction.CountIf(Worksheets("Ark2").Range("B:B"), Cells(x, 3)) = 0 Then
Cells(x, 3).Copy Destination:=Worksheets("Ark2").Cells(y, 2)
y = y + 1
End If
Next
Application.Calculation = xlAutomatic
End Sub

I sidste celle står der altid Hovedtotal
Kan man undgå at få denne med over. Så den stopper ved Hovedtotal

Det data i en kube

LN

Ja, så skal du blot ændre
For x = 6 To LastRow

til
For x = 6 To LastRow - 1

ahh selvfølgelig

Kan man få en lille krølle at den kun skal tage de første 30 tegn i hver celle og flytte over?? 

Og taaak

LN

Prøv med

Sub Flyt()
Dim LastRow, x, y As Long
Dim z As String
Application.Calculation = xlManual
Worksheets("Ark2").Range("B9:B1000").ClearContents
y = 9
LastRow = Range("C:C").SpecialCells(xlCellTypeLastCell).Row
For x = 6 To LastRow - 1
z = Left(Cells(x, 3), 30)
If Application.WorksheetFunction.CountIf(Worksheets("Ark2").Range("B:B"), z) = 0 Then
Worksheets("Ark2").Cells(y, 2) = z
y = y + 1
End If
Next
Application.Calculation = xlAutomatic
End Sub