Sorteren dmv VBA

Status
Niet open voor verdere reacties.
T

Tsw

Gebruiker
Lid geworden
5 dec 2011
Berichten
183
Hallo,

Het volgende gaat bij het toegevoegde bestand:

Ik heb in sheet ''DATA'', alle gegevens ingevuld. in 1 regel staat alles over het werknummer dat vooraan staat. (een werknummer kan meerdere deelleveringen hebben.)

Maar eigenlijk wil ik alle gegevens gesorteerd op datum in sheet ''PLANNING" hebben staan.
Dus bij de sheet "DATA" staat één werk met alle deelleveringen achter elkaar.
En in de sheet "PLANNING" wil ik het hele werk gesplitst hebben per deellevering, en leverdatum.
Is dit mogelijk via een VBA code? (Ik ga er vanuit dat dit met =VERTICAAL.ZOEKEN moet maar ik kom er maar niet uit.)

Hierbij het bestand waar het uitgewerkt is.
Bekijk bijlage Voorbeedl1.xlsx

Alvast bedankt voor jullie tijd en hulp!
 
Laat de code eens lopen, en kijk voor het resultaat op blad 'test'.
Code: 
Sub hsv()
Dim i As Long, j As Long, jj As Long, n As Long, x As Long, xx As Long, arr
With Sheets("Data")
ReDim arr(.UsedRange.Cells.Count, 10)
  For i = 2 To .Range("A1").End(xlDown).Row
  For j = 4 To .Cells(i, Columns.Count).End(xlToLeft).Column Step 8
        arr(n, 0) = .Cells(i, 1)
        arr(n, 1) = .Cells(i, 2)
        arr(n, 2) = .Cells(i, 3)
      For jj = j To j + 7
        arr(n, 3 + xx) = .Cells(i, jj)
        xx = xx + 1
      Next jj
          n = n + 1
         xx = 0
    Next j
   Next i
    With Sheets("test").Cells(1)
     .CurrentRegion.Offset(1).ClearContents
     .Offset(1).Resize(n, 11).Value = arr
   End With
 End With
End Sub
 

Bijlagen

  • definitief.xlsm
    18,9 KB · Weergaven: 69
Laatst bewerkt:
Werkt goed zoals ik het nu zie, kan er ook een automatisch sorteren op datum.
Oudste datum boven?

En zou jij de code kunnen uitleggen, ik kom er niet uit. Want als ik hem een keer wil aanpassen. (bijv. deellevering meer krijgen)
Dan zou ik hem graag makkelijk kunnen aanpassen.

Alvast bedankt!
 
Laatst bewerkt:
Je werkblad kan je net zover uitbreiden naar rechts en naar onderen als je wil.
Alleen in achtneming dat je naar rechts de structuur van 8 kolommen aanhoud (deellevering t/m leverdatum).
Ik heb er een beschrijving bij gedaan, en er wordt gesorteerd op leverdatum.
Code: 
Sub hsv()
Dim i As Long, j As Long, jj As Long, n As Long, x As Long, xx As Long, arr
With Sheets("Data")
ReDim arr(.UsedRange.Cells.Count/24, 10) 'de grootte van de array bepalen; alle cellen/24 voor de rijen diep, en 0 tot 10 is 11 kolommen breed.
  For i = 2 To .Range("A1").End(xlDown).Row   'loop alle rijen van boven naar beneden af.
  For j = 4 To .Cells(i, Columns.Count).End(xlToLeft).Column Step 8  'vanaf kolom 4 t/m laatst gevulde kolom in stappen van 8.
        arr(n, 0) = .Cells(i, 1)   'vul de array met de gegevens van de eerste kolom.
        arr(n, 1) = .Cells(i, 2)   'vul de array met de gegevens van de tweede kolom.
        arr(n, 2) = .Cells(i, 3)   'vul de array met de gegevens van de derde kolom.
      For jj = j To j + 7          'vanaf kolom waar j voor staat t/m  j + 7.
        arr(n, 3 + xx) = .Cells(i, jj)  'vul de array met de gegevens van de kolom waar de waarde jj voor staat.
        xx = xx + 1
      Next jj
          n = n + 1
         xx = 0
    Next j
   Next i
     With Sheets("test").Cells(1)                'doe alles in blad 'test' vanaf cel A1.
      .CurrentRegion.Offset(1).ClearContents     'wis alle gegevens onder A1.
        If n > 0 Then                                'wegschrijven als er gegevens zijn.
         .Offset(1).Resize(n, 11).Value = arr       'schrijf de array weg onder A1.
         .CurrentRegion.Offset(1).Sort .Range("K2") 'sorteren op Leverdatum.
        End If
    End With
 End With
End Sub
 
Laatst bewerkt:
Bedankt voor de hulp heb ik veel aan. Zou jij voor mij de code kunnen maken als er 10 kolommen ipv 8 kolommen zijn.
Kan ik even dat verschil zien en dan zet ik het topic op opgelost. :)

Alvast bedankt voor de hulp, ben al een stuk verder nu!
 
Dan ziet het er zo uit.
Overbodige stukjes code nog verwijderd (was blijven staan tijdens test).
Code: 
Sub hsv()
Dim i As Long, j As Long, jj As Long, n As Long, x As Long, xx As Long, arr
With Sheets("Data")
ReDim arr(.UsedRange.Cells.Count / 26, 12) 'de grootte van de array bepalen; alle cellen/26 voor de rijen diep, 0 tot 12 is 13 kolommen.
  For i = 2 To .Range("A1").End(xlDown).Row   'loop alle rijen van boven naar beneden af.
  For j = 4 To .Cells(i, Columns.Count).End(xlToLeft).Column Step 10  'vanaf kolom 4 t/m laatst gevulde kolom in stappen van 10.
        arr(n, 0) = .Cells(i, 1)   'vul de array met de gegevens van de eerste kolom.
        arr(n, 1) = .Cells(i, 2)   'vul de array met de gegevens van de tweede kolom.
        arr(n, 2) = .Cells(i, 3)   'vul de array met de gegevens van de derde kolom.
      For jj = j To j + 9          'vanaf kolom waar j voor staat t/m  j + 7.
        arr(n, 3 + xx) = .Cells(i, jj)  'vul de array met de gegevens van de kolom waar de waarde jj voor staat.
        xx = xx + 1
      Next jj
         n = n + 1
         xx = 0
    Next j
    x = 0
   Next i
     With Sheets("test").Cells(1)                'doe alles in blad 'test' vanaf cel A1.
      .CurrentRegion.Offset(1).ClearContents     'wis alle gegevens onder A1.
        If n > 0 Then                                'wegschrijven als er gegevens zijn.
         .Offset(1).Resize(n, 13).Value = arr       'schrijf de array weg onder A1.
         .CurrentRegion.Offset(1).Sort .Range("K2") 'sorteren op Leverdatum.
        End If
    End With
 End With
End Sub
 
Laatst bewerkt:
Geweldig! Bedankt voor de snelle en goede hulp! Deze vraag is opgelost!
 
@HSV

Hoe minder interaktie met het werkblad (lezen/schrijven), hoe sneller de code.
Lees dus meteen zoveel mogelijk gegevens in in een variabele en werk daarmee.

Zo kan het ook (en sneller)

Code: 
Sub M_snb()
  sn = Sheets("Data").Cells(1).CurrentRegion
   
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      For jj = 1 To 3
        If sn(j, 8 * (jj - 1) + 4) <> "" Then .Item(.Count) = Application.Index(sn, j, Split("1 2 3 " & Join(Evaluate("transpose(8*(" & jj & "-1)+row(4:11))"))))
      Next
    Next
        
    Sheets("test").Cells(2, 1).Resize(.Count, 11) = Application.Index(.Items, 0, 0)
  End With
End Sub
 
Laatst bewerkt:
Een zeer mooie code @snb.
Qua snelheid meet ik ze hier gelijk, maar het zal ongetwijfeld op meerdere rijen zijn effect hebben.

Onderstaand stukje is wel weer hoogstaand hoor. :thumb:
Code: 
If sn(j, 8 * (jj - 1) + 4) <> "" Then .Item(.Count) = Application.Index(sn, j, Split("1 2 3 " & Join(Evaluate("transpose(8*(" & jj & "-1)+row(4:11))"))))
 
HSV,

Bij jou formule doet het niet meer 100%

Ik heb nu 12 deelleveringen (ipv 3 wat jij had gemaakt). maar nu neemt hij elleen de eerste regel mee op het blad "DATA" en de 2e neemt hij niet meer mee?
Waar lees ik overheen?
 
Zet het bestandje hier eens neer met de code zodat ik kan zien waar je aan hebt gesleuteld.
 
Bedankt voor het reageren. Maar ik ben in de code van snb gaan pluizen. En ben er uitgekomen. Dus het is opgelost dmv de code van snb. Maar alsnog bedankt
 
Ik loop toch nog tegen een fout aan.
De code hieronder zorgt er voor dat de 4e ingevulde cel t/m de 15e ingevulde cel worden overgeslagen.
Maar nu heb ik het probleem. Tussen die 2 cellen worden niet altijd alle waarden ingevuld. Dus er zitten soms ook lege cellen tussen. Maar deze slaat hij dan over dan gaat hij de 16e cel ook overslaan. Maar dat is niet de bedoeling. Is dit aan te passen?

Dus eigenlijk moeten de kolommen D t/m O worden uitgesloten in het tabblad DATA.

Code: 
Sub Sorteren()
    Range("A5:K50").Select
    Selection.ClearContents
  sn = Sheets("Data").Cells(1).CurrentRegion
   
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      For jj = 1 To 12
        If sn(j, 8 * (jj - 1) + 4) <> "" Then .Item(.Count) = Application.Index(sn, j, Split("1 2 3 " & Join(Evaluate("transpose(8*(" & jj & "-1)+row(16:23))"))))
      Next
    Next
        
    Sheets("PLANNING").Cells(5, 1).Resize(.Count, 11) = Application.Index(.Items, 0, 0)
  End With
End Sub
 
Laatst bewerkt:
Code: 
Sub M_snb()
  Range("A5:K50").ClearContents
  sn = Sheets("Data").Cells(1).CurrentRegion.resize(,23)
   
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      For jj = 1 To 12
        If sn(j, 8 * (jj - 1) + 4) <> "" Then .Item(.Count) = Application.Index(sn, j, Split("1 2 3 " & Join(Evaluate("transpose(8*(" & jj & "-1)+row(16:23))"))))
      Next
    Next
        
    Sheets("PLANNING").Cells(5, 1).Resize(.Count, 11) = Application.Index(.Items, 0, 0)
  End With
End Sub
 
Dan krijg ik een foutmelding bij: If sn(j, 8 * (jj - 1) + 4) <> "" Then
 
Dan haal die Resize toch gewoon weeer weg ?
 
Ja dat snap ik, maar het is niet mogelijk om op het blad data de kolommen D t/m O uit te schakelen?
Als er nou wel of juist niets aan staat, hij moet niet worden meegenomen in de formule. Is dit te doen?
 
Gewoon de code analyseren en aanpassen.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan