hulp bij sorteren na filteren per tabblad

[PingoExcel]

Hi

Om data te verdelen over verschillende tabbladen gebruik ik

Sub UitgebreidFilterenCategory()
Dim c As Range, sh As Worksheet, Bladnaam As String
With Sheets("ME Totaal")
.Columns("AF").ClearContents
.Columns("A").AdvancedFilter xlFilterCopy, , .Range("AF1"), True
For Each c In .Columns("AF").SpecialCells(xlConstants)
If c.Row > 1 Then
.Range("AE1").Value = .Range("AF1").Value
.Range("AE2").Value = c.Value
On Error Resume Next
Bladnaam = Replace(c.Value, "/", "_")
Set sh = Nothing: Set sh = Worksheets(Bladnaam)
On Error GoTo 0
If sh Is Nothing Then
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Bladnaam
Set sh = ActiveSheet
sh.Cells.ClearContents
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, .Range("AE1:AE2"), sh.Range("A1"), False
sh.Cells.EntireColumn.AutoFit
End If
End If
Next
End With
End Sub

Nu Wil ik heel graag dat hij ook nog kolom N sorteert op grootte. Daarvoor heb ik het volgende gevonden :

Sub Macro1()



' Macro1 Macro



'



Range("A2:A8").Select



ActiveWorkbook.Worksheets("Blad1").Sort.SortFields.Clear _



ActiveWorkbook.Worksheets("Blad1").Sort.SortFields.Add _



Key:=Range("A2:A8"), _



SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal



With ActiveWorkbook.Worksheets("Blad1").Sort



.SetRange Range("A2:A8")



.Header = xlGuess



.MatchCase = False



.Orientation = xlTopToBottom



.SortMethod = xlPinYin



.Apply



End With



End Sub

Hoe krijg ik dat nu in de vorige VBA erbij zodat hij dit in 1 keer doet?

Bekijk bijlage 8483 ME Test per tabblad 30-5.xlsm

 

[Gijsbert1]

zoiets?

Sub UitgebreidFilterenCategory()
  Dim c As Range, sh As Worksheet, Bladnaam As String
  With Sheets("ME Totaal")
    .Columns("AF").ClearContents
    .Columns("A").AdvancedFilter xlFilterCopy, , .Range("AF1"), True
    For Each c In .Columns("AF").SpecialCells(xlConstants)
      If c.Row > 1 Then
        .Range("AE1").Value = .Range("AF1").Value
        .Range("AE2").Value = c.Value
        On Error Resume Next
        Bladnaam = Replace(c.Value, "/", "_")
        Set sh = Nothing: Set sh = Worksheets(Bladnaam)
        On Error GoTo 0
        If sh Is Nothing Then
          Worksheets.Add after:=Sheets(Sheets.Count)
          ActiveSheet.Name = Bladnaam
          Set sh = ActiveSheet
          sh.Cells.ClearContents
          .Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, .Range("AE1:AE2"), sh.Range("A1"), False
          sh.Cells.EntireColumn.AutoFit
      End If
      End If
    Next
  End With
  
      Worksheets("ME Totaal").Select
      Range("N1").Select
    
    ActiveWorkbook.Worksheets("ME Totaal").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ME Totaal").Sort.SortFields.Add Key:=Range("N1"), _
        SortOn:=xlSortOnValues, Order:=[U][COLOR="#FF0000"][B]xlDescending[/B][/COLOR][/U], DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ME Totaal").Sort
        .SetRange Range("A2:S285")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub

Verander het rood gemarkeerde stukje tekst xlDescending (aflopend sorteren) in xlAscending als het juist oplopend gesorteerd moet worden.

 

[PingoExcel]

Hi Gijs,

Dank voor je reactie. Hij geeft geen foutmelding, verdeelt de tabbladen, maar sorteert nog niet.
Hi zet wel in het ME Totaal de totaal omzet bovenaan. Dit komt vast door sorteren.

Het gaat denk ik erom waar we deze tekst toevoegen, helaas heb ik er geen kaas van gegeten.

thx Menno

 

[Gijsbert1]

Wat (welke kolom, op welk tabblad) moet er dan gesorteerd worden?
Is mij niet echt duidelijk zo.

maar sorteert nog niet......... Dit komt vast door sorteren.