Sorteren van meerdere groepen cellen in 1 kolom

[spQQkrijder]

Wie kan mij helpen?

Ik heb verschillende groepen cellen in kolom A. Deze wil allemaal afzonderlijk gesorteerd hebben op alfabetische volgorde. Zie voorbeeld in excel. In het voorbeeld zijn het 3 groepen, maar het gaat om meerdere groepen.
Is er een formule of VBA code die dit kan uitvoeren?

Bekijk bijlage Helpmij1.xlsx

Mvg,

Den

 

[HSV]

Als je de groepen afzonderlijk selecteert en sorteert op A-Z en bij de vraag "wat wilt u doen?:"
Het optierondje "Doorgaan met de huidige selectie" selecteren.
Dus twee herhalingen voor alle drie de groepen.

Selecteer daarna kolom A of gewoon de cellen van toepassing.
Selectie kopiëren → cel B1 selecteren → Plakken Speciaal → Waarden aanvinken → OK → Enter.

 

[HSV]

Of geautomatiseerd.
Druk Alt+F8 en voer de code HSV uit.

Sub HSV()
For HS = 1 To 3
 Cells(Rows.Count, 2).End(xlUp).Offset(1) = " "
  B = Cells(Rows.Count, 2).End(xlUp).Offset(1).Address
For i = 2 + A To 10 + A
 If Cells(i, 1) > 0 Then
   Cells(Rows.Count, 2).End(xlUp).Offset(1) = Cells(i, 1)
  End If
 Next
Range(B, Cells(Rows.Count, 2).End(xlUp)).sort Range(B), , , , , , , xlYes
   A = A + 10
  Next
End Sub

 

[spQQkrijder]

Beste Harry,

Bedankt voor je medewerking. Die VBA code is precies wat ik zoek. Alleen gaat het in het voorbeeld om 3 categorieën. Maar ik heb een code nodig voor 12 categorieën. Sommige categorieën bevatten wel 150 cellen.

Ik heb een nieuw voorbeeld gemaakt. Zou jij de formule kunnen aanpassen op dit voorbeeld?
Het zou mij echt een heleboel werk schelen.

Bekijk bijlage Helpmij1 Spookrijder.xlsm

Alvast bedankt,

Den

 

[WHER]

Probeer deze macro eens, ook alt+F8 en vervolgens de macro "tst" uitvoeren.

 

[spQQkrijder]

Beste Wher,


Werkelijk waar, hoe jullie dat voor elkaar krijgen...respect!!!

Het werkt maar nog niet helemaal. Zie excel bijlage.

Bekijk bijlage Helpmij1 Spookrijder.xlsm

Alvast bedankt,

Dencre

 

[HSV]

Maak van .clearcontents in de code van WHER .clear

Zoek het groene eens op in de code, en voeg het rode toe.

 [COLOR="#00FF00"][COLOR="#008000"]If cl.Font.Bold = True Then[/COLOR][/COLOR] 
 [COLOR="#FF0000"] With Cells(i, 2).Font
    .Size = 14
    .Bold = True
    .Underline = xlUnderlineStyleSingle
   End With[/COLOR]
  [COLOR="#00FF00"][COLOR="#008000"]End If
  i = i + 1[/COLOR][/COLOR]

 

[spQQkrijder]

Harry,

Het werkt....dank je daarvoor. Maar als ik de formule wil uitvoeren in kolom V en output naar Z, krijg ik geen
output in Z.


Sub tst()
Dim rng As Range, cl As Range, temp As Integer, i As Long
Set rng = Range("V2:V" & Cells(Rows.Count, 1).End(xlUp).Row)
Range("Z:Z").Clear
i = 1
temp = 2
For Each cl In rng
If cl.Value <> "" Then
i = IIf(cl.Font.Bold, i + 1, i)
Cells(i, 2) = cl.Value
If cl.Font.Bold = True Then
With Cells(i, 2).Font
.Size = 14
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
End If
i = i + 1
If cl.Font.Bold = True Or cl.Row - 1 = rng.Rows.Count Then


If i > 3 Then
If cl.Row - 1 = rng.Rows.Count Then
i = i + 1
End If
Range(Cells(temp + 1, 2), Cells(i - 2, 2)).Select

With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Selection
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
temp = i - 1
End If
End If
End If
Next
Range("Z1").Select
End Sub

Wat gaat er fout??

Alvast bedankt,

Dencre

 

[WHER]

spQQkrijder,
Rekening houdend met de opmerkingen van Harry, en met de gegevens in kolom V (zoals ik meen te begrijpen uit je aanpassingen):

 

[spQQkrijder]

Heren,

Het is bijna gelukt!! Zie sheet voor de info.

Alvast bedankt,

DenBekijk bijlage Helpmij1 Spookrijder-2.xlsm

 

[WHER]

Pas de macro "Kleuren" aan als volgt en test eens.

Sub Kleuren()

Dim rCel As Range
Dim iStp As Integer

    
    For Each rCel In Range("Z2:Z" & Cells(Rows.Count, 26).End(xlUp).Row)
        iStp = InStr(1, rCel, "-") - 1
        With rCel.Characters(1, iStp).Font
            .Color = vbBlue
            .Underline = True
        End With
    Next
End Sub

 

[spQQkrijder]

Het werkt in de voorbeeld sheet, maar in mijn werksheet lukt het niet.

Ik krijg een error Runtime error '9' subscript out of range. Zie vet gedrukt.

Sub tst()
Dim rng As Range, cl As Range, temp As Integer, i As Long
Set rng = Range("V2:V" & Cells(Rows.Count, 22).End(xlUp).Row)
Range("Z:Z").Clear
i = 1
temp = 2
For Each cl In rng
If cl.Value <> "" Then
i = IIf(cl.Font.Bold, i + 1, i)
Cells(i, 26) = cl.Value
If cl.Font.Bold = True Then
With Cells(i, 26).Font
.Size = 14
.Bold = True
.Underline = xlUnderlineStyleSingle
End With


End If
i = i + 1
If cl.Font.Bold = True Or cl.Row - 1 = rng.Rows.Count Then


If i > 3 Then
If cl.Row - 1 = rng.Rows.Count Then
i = i + 1
End If
Range(Cells(temp + 1, 26), Cells(i - 2, 26)).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Selection, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets("Sheet1").Sort
.SetRange Selection
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
temp = i - 1
End If
End If
End If
Next
Range("Z1").Select
End Sub

 

[WHER]

Je "echte" worksheet heet toch "Sheet1" hoop ik?
Ook graag code tussen code-tags plaatsen voor de leesbaarheid.

 

[HSV]

Excel 2003 kent zo te zien .Sortfield niet.
Ook sorteert het de laatste rijen niet, en dat komt doordat er iets staat in cel V698, maar wat weet ik niet (geen spatie)
Ik laat even de rng.rows.count in cel W1 zetten, maar dit is niet de End(xlup).row
Code iets veranderd.
Alleen dat laatste moet je nog even ergens uitzoeken dus, of de laatste zogenaamde lege cellen deleten om te testen dat het daarna wel gewoon sorteert.

Sub tst()
Dim rng As Range, cl As Range, temp As Integer, i As Long
Set rng = Range("V2:V" & Cells(Rows.Count, 22).End(xlUp).Row)
Range("W1") = rng.Rows.Count
Columns(26).Clear
i = 1
temp = 2
For Each cl In rng
 If cl.Value <> "" Then
 i = IIf(cl.Font.Bold, i + 1, i)
  Cells(i, 26) = cl.Value
  If cl.Font.Bold = True Then
   With Cells(i, 26).Font
    .Size = 14
    .Bold = True
    .Underline = xlUnderlineStyleSingle
   End With
  End If
  i = i + 1
   If cl.Font.Bold = True Or cl.Row = rng.Rows.Count + 1 Then
     If i > 3 Then
       If cl.Row - 1 = rng.Rows.Count Then
        i = i + 1
       End If
     Range(Cells(temp + 1, 26), Cells(i - 2, 26)).Sort Cells(temp, 26)
    temp = i - 1
   End If
  End If
 End If
Next
End Sub

 

[spQQkrijder]

Harry & WHER,

Het werkt ik wil jullie ontzettend bedanken voor het meedenken.

Gr.

Den

 

[popipipo]

Sinds wanneer ligt Zutphen in Groningen?
en s'Hertogenbosch moet 's-Hertogenbosch zijn.
Foutje moet kunnen :d :d

 

[spQQkrijder]

Heren,

Ik heb toch nog een foutje ontdekt. Ik wil de provincies niet blauw gekleurd.
Maar zwart vet en onderstreept. De steden een tint lichter blauw.

Is dat mogelijk?


Alvast Bedankt,

Den

 

[HSV]

Zo bedoel je?

Sub tst()
Dim rng As Range, cl As Range, temp As Integer, i As Long
Set rng = Range("V2:V" & Cells(Rows.Count, 22).End(xlUp).Row)
Range("W1") = rng.Rows.Count
Columns(26).Clear
i = 1
temp = 2
For Each cl In rng
 If cl.Value <> "" Then
 i = IIf(cl.Font.Bold, i + 1, i)
  Cells(i, 26) = cl.Value
  If cl.Font.Bold = True Then
   With Cells(i, 26).Font
    .Size = 14
    .Bold = True
    .Underline = xlUnderlineStyleSingle
   End With
  End If
  i = i + 1
   If cl.Font.Bold = True Or cl.Row = rng.Rows.Count + 1 Then
     If i > 3 Then
       If cl.Row - 1 = rng.Rows.Count Then
        i = i + 1
       End If
     With Range(Cells(temp + 1, 26), Cells(i - 2, 26))
     .Sort Cells(temp, 26)
     .Font.ColorIndex = 32
     End With
    
    temp = i - 1
   End If
  End If
 End If
Next
End Sub

 

[spQQkrijder]

ja, maar nog niet helemaal. Provincies staan goed nu. Zwart, onderstreept en de juiste grootte.
De steden moet blauw gekleurd en onderstreept zijn.
Na de steden heb ik een liggend streepje. Na het liggend streepje moet de tekst weer zwart en niet onderstreept zijn.
NOORD-HOLLAND
Amsterdam - Oost

Dat staat in de macro sub kleuren,

Lastig he?