Kunde ordre skal smides i hvert sit ark, VBA

Du kan lave en pivot og så bruge dennes  "show pivot filter pages"

Hvis du navngiver dit hovedark "DATA", så skulle følgende kode gøre det


Public Sub FlytKunder()
    Dim rk As Long, I As Long, RW As Long, Navn As String
    rk = ActiveSheet.UsedRange.Rows.Count
    OldSheets = "DATA"
    For I = rk To 2 Step -1
  Navn = Range("F" & I)
        ErSidenOprettet Navn, OldSheets
        RW = Worksheets(Navn).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
      Worksheets(OldSheets).Rows(I & ":" & I).Cut Worksheets(Navn).Range("A" & RW)
      ' If I = 8 Then Stop
    Next
Call Sortering
End Sub

Sub ErSidenOprettet(Navn As String, OldSheets)
    If Navn = "" Then Navn = "Per" And OldSheets = "Ark1"
    Dim I As Integer
    For I = 1 To ActiveWorkbook.Worksheets.Count
        If Worksheets(I).Name = Navn Then Exit Sub
    Next
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Navn
    Worksheets(OldSheets).Activate
    Rows("1:1").Copy Worksheets(Navn).Range("A1")
End Sub

Sub Sortering()
Dim RW As Long
    For I = 1 To ActiveWorkbook.Worksheets.Count
        If Worksheets(I).Name <> "DATA" Then
       
            Worksheets(I).Select
            RW = (Range("A1").End(xlDown).Row) - 1
            Columns("A:F").Select
         
            ActiveWorkbook.Worksheets(I).Sort.SortFields.Clear
          ActiveWorkbook.Worksheets(I).Sort.SortFields.Add2 Key:=Range("A2:A" & RW), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With ActiveWorkbook.Worksheets(I).Sort
                .SetRange Range("A1:F" & RW)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End If
    Next
    Worksheets("DATA").Activate
End Sub

Hej kabbak

Tusind tak for dit forslag, får dog denne fejlmeddelelse:

Run-time error '438':
Object doesn't support this property or method

Kommer i denne:
ActiveWorkbook.Worksheets(I).Sort.SortFields.Add2 Key:=Range("A2:A" & RW), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

Har du andre ark, som ikke er data i, altså tomme.  Det må der ikke  være

Nej har kun DATA arket, som bliver tømt efterhånden. Kun A1:F1 står tilbage.

Hvordan udplukker jeg kun det data jeg skal bruge, for jeg skal f.eks. ikke have B kolonnen med?

prøv

Public Sub FlytKunder()
    Dim rk As Long, I As Long, RW As Long, Navn As String
    rk = ActiveSheet.UsedRange.Rows.Count
    OldSheets = "DATA"
    For I = rk To 2 Step -1
        Navn = Worksheets(OldSheets).Range("F" & I)
        ErSidenOprettet Navn, OldSheets
        RW = Worksheets(Navn).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
        Worksheets(OldSheets).Range("A" & I & ",C" & I & ":F" & I).Copy Worksheets(Navn).Range("A" & RW)
        Worksheets(OldSheets).Rows(I & ":" & I).Delete Shift:=xlUp
    Next
    Call Sortering
End Sub

Sub ErSidenOprettet(Navn As String, OldSheets)
    If Not WorksheetExists(Navn) Then
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Navn
        Worksheets(OldSheets).Activate
        Worksheets(OldSheets).Range("A1,C1:F1").Copy Worksheets(Navn).Range("A1")    ' overskrifter
    End If

End Sub

Sub Sortering()
    Dim RW As Long
    For Each WS In Worksheets
        If WS.Name <> "DATA" Then

            WS.Activate
            With WS
                RW = (.Range("A1").End(xlDown).Row) - 1
                Columns("A:E").Select

                .Sort.SortFields.Clear
                .Sort.SortFields.Add2 Key:=Range("A2:A" & RW), _
                                      SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                With .Sort
                    .SetRange Range("A1:E" & RW)
                    .Header = xlYes
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
            End With

        End If
    Next
    Worksheets("DATA").Activate
End Sub


Function WorksheetExists(ByVal Arknavn As String) As Boolean
    Dim Ark As Worksheet
    For Each Ark In ThisWorkbook.Worksheets
        If Application.Proper(Ark.Name) = Application.Proper(Arknavn) Then
            WorksheetExists = True
            Exit Function
        End If
    Next Ark
    WorksheetExists = False
End Function

Udemærket forslag Kabbak.

Nu sætter den ikke i de rigtige kolonner nu, således at den springer nogle felter over.
Og den tager ikke det hele med, der står kun én ordre pr. kunde nu i arket.

Endnu engang, tusind tak for dit forslag!!