Kolommen sorteren

Status
Niet open voor verdere reacties.
W

Woffels

Gebruiker
Lid geworden
8 jan 2006
Berichten
251
Ik wil in een tabel kolommen met vba kunnen groeperen op basis van de tekst die achter de underscore in de header staat. In het voorbeeld de tabel vóór groeperen en wat ik precies wil na groeperen in de tweede tabel. Het aantal kolommen kan variëren, maar er zit altijd een repeterend gedrag in de kolommen. De gegroepeerde tabel vervangt de ongegroepeerde tabel. In mijn voorbeeld wel twee tabellen, maar dat is alleen voor de uitleg.

Dus voor: a_xx, a_yy, a_zz, b_xx, b_yy, b_zz, c_xx, c_yy, c_zz enz...

Na: a_xx,b _xx, c_xx, a_yy, b_yy, c_yy, a_zz, b_zz, c_zz enz..

De variatie vóór de underscore kan van alles zijn, ook een string. De variatie achter de underscore ook, maar repeteert wel steeds. In mijn voorbeeld slechts 3 varianten, maar dat kunnen er dus meer zijn. In feite dus alleen kijken naar wat er achter de underscore staat. Totaal aantal regels in de tabel is onbekend.
 

Bijlagen

Kan ook alleen met deze macro met alles in geheugen.

Code: 
Sub jec()
 Dim ar, x, xp, j As Long, jj As Long
 With Sheets(1).ListObjects(1)
   ar = .HeaderRowRange
   For j = 1 To UBound(ar, 2)
     For jj = j + 1 To UBound(ar, 2)
       If Split(ar(1, jj), "_")(1) < Split(ar(1, j), "_")(1) Then
          xp = ar(1, jj)
          ar(1, jj) = ar(1, j)
          ar(1, j) = xp
       End If
     Next
   Next
    x = Application.Match(ar, .HeaderRowRange, 0)
   .HeaderRowRange = Application.Index(.Range, , x)
   .DataBodyRange = Application.Index(.DataBodyRange, Evaluate("row(1:" & .ListRows.Count & ")"), x)
 End With
End Sub
 
Laatst bewerkt:
Oplossing van AHulpje werkt, waarvoor dank. De oplossing van JEC is wat eleganter en veel sneller als er veel kolommen en regels zijn, alleen de sortering van het teken van voor de underscore is steeds anders en zou ik steeds hetzelfde willen zien. In dit geval abc-abc-abc-abc

abc.PNG
 
Zo dan?

Code: 
Sub jec()
 Dim ar, x, sp, sp2, xp, j As Long, jj As Long
 With Sheets(1).ListObjects(1)
   ar = .HeaderRowRange
   For j = 1 To UBound(ar, 2)
     For jj = j + 1 To UBound(ar, 2)
       sp = Split(ar(1, j), "_")
       sp2 = Split(ar(1, jj), "_")
       If sp2(1) < sp(1) Then
          xp = ar(1, jj)
          ar(1, jj) = ar(1, j)
          ar(1, j) = xp
       ElseIf sp2(1) = sp(1) Then
          If sp2(0) < sp(0) Then
            xp = ar(1, jj)
            ar(1, jj) = ar(1, j)
            ar(1, j) = xp
          End If
      End If
     Next
   Next
    x = Application.Match(ar, .HeaderRowRange, 0)
   .HeaderRowRange = Application.Index(.Range, , x)
   .DataBodyRange = Application.Index(.DataBodyRange, Evaluate("row(1:" & .ListRows.Count & ")"), x)
 End With
End Sub
 
Mocht je office 365 hebben, dan kun je application.sort gebruiken waardoor je code een stuk korter wordt.

Code: 
Sub jec()
 Dim xAp As Application, ar, it, x As Long
 Set xAp = Application
 With Sheets(1).ListObjects(1)
    ReDim ar(.ListColumns.Count - 1, 2)
    For Each it In .HeaderRowRange
      ar(x, 0) = Split(it, "_")(0)
      ar(x, 1) = Split(it, "_")(1)
      ar(x, 2) = it
      x = x + 1
    Next
    ar = xAp.Transpose(xAp.Match(xAp.Index(xAp.Sort(ar, [{2,1}]), , 3), .HeaderRowRange, 0))
   .HeaderRowRange = xAp.Index(.Range, , ar)
   .DataBodyRange = xAp.Index(.DataBodyRange, Evaluate("row(1:" & .ListRows.Count & ")"), ar)
 End With
End Sub
 
Laatst bewerkt:
Ter vergelijking de gesorteerde tabel 10 rijen onder de huidige geplaatst.
Als de Tabel [Table1] heet:

Code: 
Sub M_snb()
  sn = Filter(Application.Index([Table1[#Headers]].Value, 1, 0), "")
  st = sn
  
  For j = 1 To UBound(sn)
    sp = Split(sn(0), "_")
    c00 = c00 & " " & Join(Filter(sn, sp(1)))
    sn = Filter(sn, sp(1), 0)
    If UBound(sn) = -1 Then Exit For
  Next
  
  sp = Split(Trim(c00))
  For j = 0 To UBound(sp)
    sp(j) = Application.Match(sp(j), st, 0)
  Next
  
  [Table1[#All]].Offset(10) = Application.Index([Table1[#All]], [row(Table1[#All])], sp)
End Sub
 
Laatst bewerkt:
Mooizo. Graag gedaan
 
Ook een duit, en simpel.
Code: 
Sub hsv()
Dim e, i As Long
With CreateObject("System.Collections.arraylist")
    For Each e In Sheets(1).ListObjects(1).HeaderRowRange
       .Add Split(e, "_")(1) & "|" & Split(e, "_")(0) & "_"
    Next
  .Sort
    For i = 0 To .Count - 1
       .Item(i) = Split(.Item(i), "|")(1) & Split(.Item(i), "|")(0)
    Next i
  Sheets(1).ListObjects(4).HeaderRowRange = .toarray
 End With
End Sub
 
De inhoud van de tabel neemt deze niet mee
 
Had ik gemist.
Code: 
Sub hsv()
Dim sv, x, e, Lo As ListObject, i As Long
Set Lo = Sheets(1).ListObjects(1)
With CreateObject("System.Collections.arraylist")
 sv = Lo.Range
  For Each e In lo.HeaderRowRange
       .Add Split(e, "_")(1) & "|" & Split(e, "_")(0) & "_"
    Next
  .Sort
    For i = 0 To .Count - 1
       .Item(i) = Split(.Item(i), "|")(1) & Split(.Item(i), "|")(0)
    Next i
  Lo.HeaderRowRange = .toarray
      x = .toarray
      With Application
        sv = .Index(sv, Evaluate("row(2:" & UBound(sv) & ")"), .Match(x, .Index(sv, 1), 0))
    End With
  Lo.DataBodyRange = sv
 End With
End Sub
 
Laatst bewerkt:
Over het hoofd gezien: advancedfilter:

Code: 
Sub M_snb()
  sn = Filter(Application.Index(ListObjects(1).Range.Value, 1, 0), "")
  y = UBound(sn) + 1
  
  For j = 1 To UBound(sn)
    sp = Split(sn(0), "_")
    c00 = c00 & " " & Join(Filter(sn, sp(1)))
    sn = Filter(sn, sp(1), 0)
    If UBound(sn) = -1 Then Exit For
  Next
  
  Cells(1, y + 2).Resize(, y) = Split(Trim(c00))
  ListObjects(1).Range.AdvancedFilter 2, , Cells(1, y + 2).Resize(, y)
End Sub


Of sorteren met een customlist:

Code: 
Sub M_snb()
  sn = Filter(Application.Index(ListObjects(1).Range.Value, 1, 0), "")
  
  For j = 1 To UBound(sn)
    sp = Split(sn(0), "_")
    c00 = c00 & " " & Join(Filter(sn, sp(1)))
    sn = Filter(sn, sp(1), 0)
    If UBound(sn) = -1 Then Exit For
  Next
  Application.AddCustomList Split(Trim(c00))

  With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
     .List = ListObjects(1).Range.Value
     Blad3.Cells(1, 100).Resize(UBound(.List, 2) + 1, .ListCount) = .Column
     Blad3.Cells(1, 100).CurrentRegion.Sort Blad3.Cells(1, 100), , , , , , , , Application.CustomListCount
     .List = Blad3.Cells(1, 100).CurrentRegion.Value
     Blad3.Cells(1, 100).CurrentRegion.ClearContents
     ListObjects(1).Range.Value = .Column
  End With
End Sub
 
Laatst bewerkt:
@Snb, Er vindt geen "harde" sortering plaats in je eerste code. Begin maar eens met "b_Gerard" ipv "a_Gerard"

Het listobject wordt overigens vervangen door een normaal bereik.
Voor hoever ik kon zien, behoud je die alleen zolang je de headers apart van in de inhoud wegschrijft.
 
@JEC

Dat is ook niet nodig:
Ik wil in een tabel kolommen met vba kunnen groeperen op basis van de tekst die achter de underscore in de header staat.
Klik om te vergroten...
 
Zoals je ziet in het resultaat van mijn suggestie, is die volgorde steeds hetzelfde, zoals gevraagd in #4.
 
Zodra je begint met een andere volgorde niet meer
 
De constantie blijft vanwege de constantie van de binnengehaalde gegevens.
 
Variant.
Code: 
Sub hsv()
Dim sv, sv_2, e, Lo As ListObject, xAp As Application, j As Long
Set Lo = Sheets(1).ListObjects(1): Set xAp = Application
With CreateObject("System.Collections.sortedlist")
 sv = Lo.Range.Value2: sv_2 = sv
    For Each e In Sheets(1).ListObjects(1).HeaderRowRange
      .Item(Split(e, "_")(1) & Split(e, "_")(0) & "_") = e
    Next
    For j = 1 To .Count
      sv_2(1, j) = .GetByIndex(j - 1)
    Next
     Lo.HeaderRowRange = xAp.Index(sv_2, 1)
     Lo.DataBodyRange = xAp.Index(sv, Evaluate("row(2:" & UBound(sv) & ")"), xAp.Match(Lo.HeaderRowRange, xAp.Index(sv, 1), 0))
  End With
End Sub
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan