sotering af af liste

spm 946441 kan måske være inspiration?

Er det her spørgsmål stadig aktuelt?

ikke super aktuel mere, men jeg har dog ikke fundet en lösning jeg synes var god. har kigget på spm 946441 men kan ikke helt få det til at virke. (noget med tid og kundskaber)

Hej igen,

Du kan jo evt. se om nedenstående kan bruges.

Jeg udgår i dette tilfælde fra, at det ark hvor du har alle dine data hedder Ark1.

-------------------------------------------------

Option Explicit

Sub Sortering()

    Dim Afd As String
    Dim RK As Long
    Dim RK1 As Long
    Dim Ax As Long
    Dim Start As String
   
    Range("H2").Select
    Range("A2:H19500").Sort Key1:=Range("H2"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
   
    Start = Cells(2, 8)
    Do
    RK = 2
    RK1 = RK - 1
    Sheets("Ark1").Select
    Do
    If Cells(RK, 8) <> Cells(RK1, 8) Then
    Afd = Cells(RK, 8)
    Sheets.Add.Name = Afd
    Sheets("Ark1").Select
    Cells.Select
    Selection.Copy
    Sheets(Afd).Select
    ActiveSheet.Paste
    Cells(2, 1).Select
    Sheets("Ark1").Select
    RK = RK + 1
    RK1 = RK1 + 1
    Else
    RK = RK + 1
    RK1 = RK1 + 1
    End If
    Loop Until Cells(RK, 1) = ""
    Loop Until ActiveSheet.Name = "Ark1"
    Application.CutCopyMode = False
    Cells(2, 1).Select
    Sheets(Start).Select
   
    Do
    RK = 2
    Afd = ActiveSheet.Name
    Do
    If Cells(RK, 8) <> Afd Then
    Cells(RK, 8).Select
    Selection.EntireRow.Delete
    Else
    RK = RK + 1
    End If
    Loop Until Cells(RK, 1) = ""
    ActiveSheet.Next.Activate
    Loop Until ActiveSheet.Name = "Ark1"
    Cells(2, 1).Select
End Sub


----------------------------------------------------

Håber det er noget Du kan bruge

Med venlig hilsen

Henrik

Hej

efter lidt arbejde fik jeg det til at fungere, smid et svar så jeg kan afslutte spgm.

tak for hjälpen

Glad for at du fik det til at virke :-)