Sorteercode

[Davebiertje01]

Goedemiddag,

Ik heb een probleem. Er moeten een aantal gegevens op diverse tabbladen gerangschikt gaan worden in de volgende tabbladen.
Tab:1:6.
Tab:2:6-10
Tab:3:6-9
Tab:4:10
Tab:5:9

In eerste instantie wordt er een lijst van +/-7000 artikelen geplakt in tab:1(Dit is de enige handmatige actie). Vervolgens worden de dubbele nummers gezocht in kolom D, deze krijgen allemaal de kleur rood(voorwaardelijke opmaak). Deze moet vervolgens (van A2:K2)geplakt gaan worden in tab2. De artikelen in Tab 2 in Kolom A die een 9 bevatten, worden geplaatst naar Tabblad 3.

Het tweede gedeelte van de code. In tab 1, staan nu nog alle enkele nummers. In kolom A van Tab 1 zullen alle artikelen met een 10 verplaatst moeten worden naar Tab 4. In Tab 1 kolom A staan nu alleen nog 6 en 9. De 9 uit kolom A van Tab 1 moeten verplaatst worden naar tab 5:.

-Onderstaande code verricht deels het werk, echter wanneer er andere gegevens handmatig ingevoerd worden in Tab 1, doet de VBA niet meer wat het zou moeten doen. Enig idee dit op te lossen?
- Tablad 5 heeft niet altijd een inhoud, hierdoor verloopt de VBA grote vertraging op heb ik het vermoeden. Is het mogelijk de code sneller te krijgen?

Sub Sorteren()
'
' Sorteren Macro
'
'
    Columns("D:D").Select
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("D1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$K$5383").AutoFilter Field:=4, Criteria1:=RGB(255, _
        199, 206), Operator:=xlFilterCellColor
    
    Range("$A$2:$K$5383").Select
    
    ActiveWindow.SmallScroll Down:=3
    Selection.Copy
    Sheets("6-10").Select
    ActiveSheet.Paste
    Sheets("6.").Select
             
    
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveSheet.Range("$A$1:$K$5383").AutoFilter Field:=4
    ActiveSheet.Range("$A$1:$K$5383").AutoFilter Field:=4, Criteria1:="<>"
    Range("A2").Select
    ActiveSheet.Range("$A$1:$K$5383").AutoFilter Field:=1, Criteria1:="9"
    Range("A2191:I2230").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("9").Select
    Range("A2").Select
    ActiveSheet.Paste
    Sheets("6.").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveSheet.Range("$A$1:$K$5383").AutoFilter Field:=1, Criteria1:="10"
    Range("A2292:I2306").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("10").Select
    ActiveSheet.Paste
    Sheets("6.").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveSheet.Range("$A$1:$K$5383").AutoFilter Field:=1
    Range("A2").Select
    ActiveWindow.SmallScroll Down:=-9
    Sheets("6-10").Select
    Range("A1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$K$749").AutoFilter Field:=1, Criteria1:="9"
    ActiveWindow.SmallScroll Down:=-18
    Range("A352:I364").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("6-9").Select
    Range("A2").Select
    ActiveSheet.Paste
    Cells.Select
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    Cells.EntireColumn.AutoFit
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.EntireColumn.AutoFit
    Sheets("6-10").Select
    Selection.ClearContents
    ActiveSheet.Range("$A$1:$K$749").AutoFilter Field:=1, Criteria1:="<>"
    Sheets("6.").Select
End Sub
Sub Delete()
'
' Delete Macro
'

'
    ActiveSheet.Range("$A$1:$K$3383").AutoFilter Field:=4
    Cells.Select
    Range("C26").Activate
    Selection.ClearContents
    Range("A1").Select
    Sheets("6-10").Select
    Cells.Select
    Range("A352").Activate
    Selection.ClearContents
    Range("A333").Select
    ActiveWindow.SmallScroll Down:=-33
    ActiveWindow.ScrollRow = 301
    ActiveWindow.ScrollRow = 297
    ActiveWindow.ScrollRow = 287
    ActiveWindow.ScrollRow = 274
    ActiveWindow.ScrollRow = 269
    ActiveWindow.ScrollRow = 250
    ActiveWindow.ScrollRow = 241
    ActiveWindow.ScrollRow = 223
    ActiveWindow.ScrollRow = 200
    ActiveWindow.ScrollRow = 186
    ActiveWindow.ScrollRow = 177
    ActiveWindow.ScrollRow = 158
    ActiveWindow.ScrollRow = 140
    ActiveWindow.ScrollRow = 117
    ActiveWindow.ScrollRow = 103
    ActiveWindow.ScrollRow = 93
    ActiveWindow.ScrollRow = 84
    ActiveWindow.ScrollRow = 70
    ActiveWindow.ScrollRow = 56
    ActiveWindow.ScrollRow = 47
    ActiveWindow.ScrollRow = 33
    ActiveWindow.ScrollRow = 24
    ActiveWindow.ScrollRow = 19
    ActiveWindow.ScrollRow = 6
    ActiveWindow.ScrollRow = 1
    Range("A1").Select
    Sheets("6-9").Select
    Range("A1:K1").Select
    Selection.Copy
    Sheets("6-10").Select
    ActiveSheet.Paste
    Sheets("6.").Select
    ActiveSheet.Paste
    Sheets("6-9").Select
    Range("A2:I8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("A2").Select
    Sheets("10").Select
    Range("A2:K9").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A2").Select
    Sheets("9").Select
    Range("A2:I5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    ActiveWindow.SmallScroll Down:=-12
    Sheets("6.").Select
    Range("A2").Select
End Sub