Sortering af data

Den nye liste skal det være på samme ark, eller et nyt ark.

Jeg går udfra det gerne må være vba kode

Det må gerne være vba kode.

Den nye liste må gerne komme i et nyt ark.

Prøv dette:

sortere kolonne B i sheet1
dobbelt i sheet2
enkelt i sheet3


Sub Button5_Click()
   
    col = 2                            ' tjek kolonne
    Set ark = Worksheets("sheet1")      ' hent fra ark
    Set tilark = Worksheets("sheet2")
    Set tilark2 = Worksheets("sheet3")
    t = 1                              ' start i række
    t2 = 1
    rk = 1
   
    ark.Select
    Columns("B:B").Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    ' sæt overskrifter
    tilark.Range(t & ":" & t).EntireRow.Value = ark.Range(rk & ":" & rk).EntireRow.Value
    tilark2.Range(t2 & ":" & t2).EntireRow.Value = ark.Range(rk & ":" & rk).EntireRow.Value
    t = t + 1
    t2 = t2 + 1
    mylastrow = ark.Cells(ark.Rows.Count, 1).End(xlUp).Offset(0, 0).Row
    For rk = mylastrow To 2 Step -1
        If Cells(rk, col).Value = Cells(rk + 1, col).Value Or Cells(rk, col).Value = Cells(rk - 1, col).Value Then
            tilark.Range(t & ":" & t).EntireRow.Value = ark.Range(rk & ":" & rk).EntireRow.Value
            t = t + 1
        Else
            tilark2.Range(t2 & ":" & t2).EntireRow.Value = ark.Range(rk & ":" & rk).EntireRow.Value
            t2 = t2 + 1
        End If
    Next rk

End Sub

Perfekt - den virker lige efter hensigten.
Tak for hjælpen - Smid et svar!

velbekomme :o)

Husk at du kun skal lægge dine svar som kommentar

Husk at accepter svaret, vælg mit navn i nedeste venstre hjørne og tryk accepter