Kolom B filteren op oneven DAARNA op even

[samui]

Kolom B filteren op oneven DAARNA op even en dat iedere keer als er iemand toegevoegd

Beste mensen,

Ik zou graag in een macro vorm kolom B vanaf B5:AD254
in 1e instantie laten sorteren op ONEVEN en daarna op EVEN,
echter hij moet wel direct mee kunnen lopen met de rest van de macro die hiervoor uitgevoerd wordt.

Even een korte uitleg erbij. De locatie wordt door mij dmv een Private Sub Worksheet_Change(ByVal Target As Range)
ingevoerd.
Als ik een x geef in bijvoorbeeld B24, komt de macro met behulp van een inputbox met de vraag wat zijn locatie moeten worden.
Ik geef bijvoorbeeld 16 in omdat plek 16 en 18 nog groen zijn ofwel nog leeg.
Daarna gaat er een leuke macro lopen die op het eind "deze ga ik invoeren" en "deze ga ik invoeren heeft 2 standplaatsen" oplevert en ook op locatie 16 en 18 staat in kolom B. In kolom A zal de locatie 16 en 18 rood gekleurd worden.
Voorbeelden hiervan zie je al ingevuld staan in de bijlage. ( In de kolom C is het begin v/e deelnemer de toevoeging ... heeft x standplaatsen regelt de macro)
Er gebeurd op diverse tabbladen zaken die allemaal in dezelfde macro uitgevoerd worden.
Aansluitend moet als laatste dan na iedere locatie invoer de zaak op ONEVEN en EVEN gesorteerd worden van ONEVEN laag naar hoog en daaronder op EVEN van laag naar hoog.
Het resultaat moet dan zijn dat onderstaande volgorde aangehouden wordt ipv de volgorde die je in de bijlage ziet.
15
17
19
21
etc.
etc.
2
20
22
24
etc.
etc.

Na invoering van mijn locatie 16 en 18 moet de rij er dus zo uitgaan zien. En zo na iedere invoer die een locatie krijgt toebedeeld.


15
17
19
21
etc.
etc.
2
16
18
20
22
24
etc.
etc.




Nu wordt de zaak alleen gesorteerd van laag naar hoog maar dat is niet goed. Het is niet overzichtelijk.

Range("b5:Ad254").Select
Selection.Sort Key1:=Range("b5"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Next x
End Sub


Mocht het niet duidelijk zijn of u wenst meer informatie vraag het en ik probeer meer info te geven.
Wie oh wie helpt mij weer uit de brand ( programma moet draaien in office 2010 ) :thumb:

Frank

 

[HSV]

Frank,

De blauwe rij weggehaald....samengevoegde cellen.
Kolom 2 vanaf onderen tot nr 34 leeggemaakt.

Sub hsv()
Dim cl As Range, c0 As String, sq, i As Long
Application.ScreenUpdating = False
For Each cl In Columns(2).SpecialCells(2, 1)
 If cl Mod 2 = 0 Then
   cl.Resize(, 29).Copy Cells(Rows.Count, 2).End(xlUp).Offset(1)
   c0 = c0 & "|" & cl.Row
    End If
  Next cl
  sq = Split(Mid(c0, 2), "|")
  For i = UBound(sq) To 0 Step -1
 Cells(sq(i), 2).Resize(, 29).Delete
 Next
End Sub

Of iets sneller.

Sub hsv()
Dim cl As Range, c0 As String
Application.ScreenUpdating = False
For Each cl In Columns(2).SpecialCells(2, 1)
 If cl Mod 2 = 0 Then
   cl.Resize(, 29).Copy Cells(Rows.Count, 2).End(xlUp).Offset(1)
   c0 = c0 & "," & cl.Address(0, 0) & ":AD" & cl.Row
    End If
  Next cl
  c0 = Mid(c0, 2)
  Range(c0).Delete xlUp
End Sub

 

[samui]

Harry,

Super dit is hem. Ik ben weer helemaal blij.
Stapje voor stapje gaat mijn bestand er steeds beter en mooier uitzien, maar soms loop ik vast en dan is dit forum ideaal om mijn vragen weg te leggen.
Nogmaals super bedankt weer het forum helpmij en jij Harry.
Ik sluit gelijk deze vraag. Wie weet heb ik binnenkort een nieuwe vraag.

Frank,

De blauwe rij weggehaald....samengevoegde cellen.
Kolom 2 vanaf onderen tot nr 34 leeggemaakt.

Sub hsv()
Dim cl As Range, c0 As String, sq, i As Long
Application.ScreenUpdating = False
For Each cl In Columns(2).SpecialCells(2, 1)
 If cl Mod 2 = 0 Then
   cl.Resize(, 29).Copy Cells(Rows.Count, 2).End(xlUp).Offset(1)
   c0 = c0 & "|" & cl.Row
    End If
  Next cl
  sq = Split(Mid(c0, 2), "|")
  For i = UBound(sq) To 0 Step -1
 Cells(sq(i), 2).Resize(, 29).Delete
 Next
End Sub

Of iets sneller.

Sub hsv()
Dim cl As Range, c0 As String
Application.ScreenUpdating = False
For Each cl In Columns(2).SpecialCells(2, 1)
 If cl Mod 2 = 0 Then
   cl.Resize(, 29).Copy Cells(Rows.Count, 2).End(xlUp).Offset(1)
   c0 = c0 & "," & cl.Address(0, 0) & ":AD" & cl.Row
    End If
  Next cl
  c0 = Mid(c0, 2)
  Range(c0).Delete xlUp
End Sub

 

[samui]

@Harry,

Uhhh sorry in mijn enthousiasme heb ik in mijn vorige reactie je naam verkeerd gezet, ik noem je per ongeluk Hans. Excuses hiervoor.
Harry, zoals je ziet is mijn probleem nog niet opgelost. Ik krijg jouw oplossing niet werkend in mijn macro.
Ook worden de nieuwe toevoegingen niet op volgorde gezet. ( is mijn fout want die vraag lag er niet voorheen )
Ik hoop dat je bovenstaande vraag als nog wilt/kunt waarmaken. Of iemand anders natuurlijk.
Ik zou er weer een heel eind mee geholpen zijn.

Alvast bedankt.

gr,
Frank

 

[HSV]

Delete de zogenaamde lege cellen in kolom B.
Er staat een spatie of iets dergelijks in.
De code zet zo de cellen verder naar onderen als dat gewenst is.

 

[samui]

Ik ben inmiddels weer een paar stappen verder en ik heb het werken zoals ik het wil.
Wederom bedankt Harry. Superrrrrrrrrrrrrrrrr