Grafiek maken met vba

[JanBG]

Hoi,

Ik heb een VBA code gemaakt om in een Excel bestand van bepaalde gegevens een grafiek te maken. Daarbij is een van de stappen dat, voordat de grafiek gegenereerd wordt de data op datum geordend worden van oud naar nieuw. Probleem dat ik heb is, dat als ik de macro draai de eerste keer die ordening niet gebeurd; draai ik de macro daarna nog een keer, wordt de ordening wel uitgevoerd. Iemand enig idee?

Dit is de code die ik heb:

Sub Grafiek()

Range("A5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range("A4:J500").Select
    Selection.Sort Key1:=Range("E5"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Sheets("Patient Individueel").Select
    Range("E5:E50").Select
    Selection.Copy
    Sheets("Blad1").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        
Sheets("Patient Individueel").Select
    Range("H5:H50").Select
    Selection.Copy
    Sheets("Blad1").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        
Sheets("Patient Individueel").Select
    Range("I5:I50").Select
    Selection.Copy
    Sheets("Blad1").Select
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        
Sheets("Patient Individueel").Select
    Range("J5:J50").Select
    Selection.Copy
    Sheets("Blad1").Select
    Range("E2").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        
Sheets("Patient Individueel").Select
    Range("G5:G50").Select
    Selection.Copy
    Sheets("Blad1").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Sheets("Blad1").Select
    Range("A1:E50").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Dim i As Range
Application.ScreenUpdating = False
Sheets("Blad1").Activate
Selection.AutoFilter Field:=1
Selection.AutoFilter Field:=2
Range("a2").EntireColumn.Hidden = False
Range("A2:C2").EntireColumn.Hidden = False

Selection.AutoFilter Field:=2, Criteria1:=Sheets("Patient Individueel").Range("L2")
For Each i In Range("A2:C2")
    If i <> Sheets("Patient Individueel").Range("L2") Then
    i.EntireColumn.Hidden = False
    End If
Next
Range("b2").EntireColumn.Hidden = False
Sheets("Grafiek").Activate
Application.ScreenUpdating = True

Sheets("Grafiek").Select

End Sub

De macro draait in het blad "Patient Individueel" en het gaat om dit deel:

Sheets("Blad1").Select
Range("A1:E50").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Dat voert de macro de 1e keer dus niet uit, de 2e keer wel

 

[VenA]

Welkom op dit forum. Gebruik svp codetags nu is het nogal onleesbaar.

Het eerste gedeelte dus t/m het sorteren van Blad1 kan je ook zo schrijven.

Sub VenA()
  With Sheets("Patient Individueel")
    .Range("A4:J500").Sort .Range("E5"), , , , , , , xlGuess
    .Range("E5:E50").Copy Sheets("Blad1").Range("B2")
    .Range("G5:G50").Copy Sheets("Blad1").Range("A2")
    .Range("H5:H50").Copy Sheets("Blad1").Range("C2")
    .Range("I5:J50").Copy Sheets("Blad1").Range("D2")
  End With
  Sheets("Blad1").Range("A1:E50").Sort Sheets("Blad1").Range("A1"), , , , , , , xlGuess
End Sub

Select en activate is meestal overbodig.

 

[JanBG]

Dank VenA,

Werkt als een zonnetje :d. Excuus, beetje te snel op verzenden geklikt, maar nu wel de code tag toegevoegd, zodat het later wel beter leesbaar is

It's never to late to do the right thing