Opdeling af data på ark samt navngivning af ark.

Sub KopierTilNyt()
             
\'returnerer rækkeantal i arket
ActiveCell.SpecialCells(xlLastCell).Select
Række = ActiveCell.Row

Rows(\"1\").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False

\'Gennemløber alle talte rækker og kopiere dem til andet ark, hvis der er noget i
\'Kolonne A
x = 1
For n = 2 To Række
If Cells(n, 1).Value <> \"\" Then
    If Cells(n, 1).Value <> Cells(n - 1, 1).Value Then
        navn = Cells(n, 1).Value
        Rows(n).Copy
        Sheets.Add After:=Worksheets(Worksheets.Count)
        Sheets(Sheets.Count).Name = navn
        x = 1
        Rows(x).Select
        ActiveSheet.Paste
        Sheets(\"Ark1\").Select
    Else
        Rows(n).Copy
        Sheets(navn).Select
        x = x + 1
        Rows(x).Select
        ActiveSheet.Paste
        Sheets(\"Ark1\").Select
End If
End If
Next n
Sheets(\"Ark1\").Select
Rows(1).Delete

End Sub

ups glemte at starte i række 10 på de nye ark:

Sub KopierTilNyt()
             
\'returnerer rækkeantal i arket
ActiveCell.SpecialCells(xlLastCell).Select
Række = ActiveCell.Row

Rows(\"1\").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False

\'Gennemløber alle talte rækker og kopiere dem til andet ark, hvis der er noget i
\'Kolonne A

For n = 2 To Række
If Cells(n, 1).Value <> \"\" Then
    If Cells(n, 1).Value <> Cells(n - 1, 1).Value Then
        navn = Cells(n, 1).Value
        Rows(n).Copy
        Sheets.Add After:=Worksheets(Worksheets.Count)
        Sheets(Sheets.Count).Name = navn
        x = 10
        Rows(x).Select
        ActiveSheet.Paste
        Sheets(\"Ark1\").Select
    Else
        Rows(n).Copy
        Sheets(navn).Select
        x = x + 1
        Rows(x).Select
        ActiveSheet.Paste
        Sheets(\"Ark1\").Select
End If
End If
Next n
Sheets(\"Ark1\").Select
Rows(1).Delete

End Sub

NB - koden virker, hvis der ingen overskrifter er - skal justeres lidt, hvis du har kolonneoverskrifter.

Da det også kunne være en brugbar makro for mig har jeg derfor forsøgt mig med rvm\'s makro, men den stopper hos mig ved 2. forekomst i kodelinien

Sheets(navn).Select

hvorfor mon ?

-> tida: Det virker som om den ikke kommer igennem det første gennemløb, hvor den opretter arket, som der henvises til i \"Sheets(navn).Select\". Har du kolonneoverskrifter?

Denne virker også og er meget hurtig.
Sub testing()
x = Application.WorksheetFunction.CountA(Range(\"A:A\"))
y = Application.WorksheetFunction.CountA(Range(\"1:1\"))
ReDim matrix(x, y)
For i = 2 To x
    For j = 1 To y
        matrix(i, j) = Cells(i, j).Value
    Next j
Next i
For i = 2 To x
  If matrix(i, 1) = matrix(i - 1, 1) Then
  AB = AB + 1
  For j = 1 To y
    Cells(AB + 9, j).Value = matrix(i, j)
  Next j
 
  Else
  Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
  ActiveSheet.Name = matrix(i, 1)
  AB = 1
  For j = 1 To y
    Cells(10, j).Value = matrix(i, j)
  Next j
  End If
Next i
End Sub

Skal vi tage tid *S*

rvm : Ja, første gennemløb funker fint, derefter er det slut. Jeg har ingen overskrifter.

bak: Der sker ikke rigtig noget, den stopper ved

If matrix(i, 1) = matrix(i - 1, 1) Then

Hallo ransborg, kom lige på banen !!!!

Prøv lige at sende det til mig, hvis du har lyst: rvejemad@sca.csc.com - så er det nemmere lige at finde fejlen :-)

Hov bak....den funker fint nu, jeg skulle bare lige slette 2 tomme rækker foroven...den er hjemme.

Vi kan splejse Ransborg !

Richardt, ok med at tage tid.
Lad lige ransborg gøre det med sine 12000 linier.

Jeg kommer lige på banen i aften, når jeg kommer hjem. Så vil jeg gennemgå jeres forslag.

MVH
Claus

PS. Jeg skal nok melde tilbage, hvilket forslag, som er hurtigst :-)

rvm, grunden til at jeg skrev at min var hurtig var ikke for at rakke ned på din, men fordi jeg selv var lidt forbavset over hastigheden *S*

Sååå, jeg overdriver nok lidt, for jeg fik den lige testet på mange (6000 rækker) og det tog 2 min.
Richardt. Din kan jeg ikke få til at køre stabilt, den stopper lidt umotiveret efter ca. 14 ark (Sheets(navn).Select), samme linienr hver gang.
Jeg har bygget lidt videre på en autofiltermodel, der klarer 12000 linier og 72 ark på 20 sek.Sub AutoFilterModel()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    x = Application.WorksheetFunction.CountA(Range(\"A:A\"))
    ReDim matrix(x)
    a = 0
    \'**Læser 1. kolonne og finder de forskellige værdier
    For i = 2 To x
        If Cells(i, 1) <> Cells(i - 1, 1) Then
        a = a + 1
        matrix(a) = Cells(i, 1).Value
        End If
    Next i
    StartArk = ActiveSheet.Name
    \'**Sætter de forskellige værdier på som autofilter og kopier resultatet
    For y = 1 To a
        StartArk = ActiveSheet.Name
        Selection.AutoFilter Field:=1, Criteria1:=matrix(y)
        Selection.CurrentRegion.Copy
        Sheets.Add
        ActiveSheet.Name = matrix(y)
        Range(\"A10\").PasteSpecial (xlPasteValues)
        Application.CutCopyMode = False
        Sheets(StartArk).Select
    Next
    Selection.AutoFilter
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Nej, jeg kunne ikke lade være. Det skulle bare gøres hurtigere. Ca. 10 sek for 12000 rækker og 72 ark.

Sub testing()
On Error GoTo errcatch
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set StartArk = ActiveSheet
Set overskrift = StartArk.Range(\"A1:X1\")
Dim x, y, i, nystart As Integer, first As Boolean
x = Application.WorksheetFunction.CountA(Range(\"A:A\"))
y = Application.WorksheetFunction.CountA(Range(\"1:1\"))
first = False
For i = 2 To x + 1
  If StartArk.Cells(i, 1) <> StartArk.Cells(i - 1, 1) Then
  If first = True Then
  overskrift.Copy
  ActiveSheet.Range(\"A10\").PasteSpecial (xlPasteValues)
  StartArk.Range(\"A\" & nystart & \":X\" & i).Copy
  ActiveSheet.Range(\"A11\").PasteSpecial (xlPasteValues)
  End If
  Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
  nystart = i
  first = True
  ActiveSheet.Name = StartArk.Cells(i, 1).Value
End If
Next i
errcatch:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Jeg ved ikke hvorfor min kode stopper ved \"Sheets(navn).Select\" - det gør den ikke i mine testdata.
Jeg kan deværre ikke hjælpe mere, da jeg tager på ferie og først er hjemme på tisrdag. Held og lykke *S*
Pointene på vist tilfalde bak, der har gjort et stort arbejde :-)

Mvh

Richardt

Til bak : Din seneste makro er muligvis hurtig, men den gør ikke det den skal hos mig, den roder rundt i data og tager ikke det første arknavn med.

Jeg vil stadig holde mig til din første makro, den er perfekt og tilmed hurtig.

Har du overskrifter med, tida??

Den virker nemlig kun hvis der er overskrifter på.
første linie kopieres nemlig med over på hvert ark.

Nej, rigtig, jeg havde ingen overskrifter.

Når jeg nu indsætter overskrift i 1. række opretter den godt nok arkene korrekt, men den medtager de forkerte data.

Nu er spørgsmålet jo ikke mit, så vi behøver ikke at koge en masse suppe på det, men på den anden side kan jeg godt lide der er orden i tingene S*

Pokkers tida, du har ret. Den sidste linie er forkert hver gang. Jeg beklager.

i makroen skal linien:
StartArk.Range(\"A\" & nystart & \":X\" & i).Copy
ændres til
StartArk.Range(\"A\" & nystart & \":X\" & i - 1).Copy

Forøvrigt hvis der ikke havde været så mange kolonne vil jeg have foretrukket at lave en pivottabel, indsætte kolonne 1 som sidefelt, højreklikket på denne, og valgt \"Vis sider\".
Så laver excel selv arbejdet.

SÅ!! nu virker turbo-versionen også...Tju-hej !

Jeg takker mange gange for hjælpen, det var en sand fornøjelse at arbejde med. Antallet af pointene viser, hvem der havde den hurtigste af løsningerne :-)

MVH
Claus


PS. tida, du skal ikke betale for det - det er heldigvis sådan, at vi kan bruge hinandens spørgsmål. Så jeg holder skam bare øje med dine :-)