Sorteren met lege rijen

[jansm]

Heren, onderstaande tabel is een verzameling gegevens van single personen en echtparen met bijbehorende datum van geboorte en overlijden. Elk single persoon en echtpaar hebben een uniek nr in . Op deze kolom wil ik sorteren, waarbij de eventuele "koppels" met kolom [C] [D] [E meegaan. Probleem voor mij zijn de lege rijen en de de namen zonder nummer. Wie wilt mij helpen?
Bekijk bijlage Sorteer_1.xlsx

 

[Haije]

jan,

waarom de lege regels niet verwijderen en bij de koppels ook de tweede in kolom B het unieke nummer geven?

zie bijlage, Blad2

 

[OctaFish]

Waarom zet je er überhaupt lege rijen tussen? En begin je niet in A1? En lege cellen zijn natuurlijk dodelijk als je wilt sorteren; je zult op zijn minst elke persoon een ID moeten geven. Dus zoiets:

 

[jansm]

heren, bedankt voor jullie reactie.
De opmaak krijg ik zo aangeleverd en, daar is iets voor te zeggen. Als overzichtsrapport is deze opmaak natuurlijk overzichtelijker dan de opmaak die jullie voorstellen (die had ik ook kunnen verzinnen). En niet in kolom A beginnen? Dit is natuurlijk een voorbeeld tabel!
Zou e.e.a mogelijk zijn met een VBA-tje?

 

[Erik191283]

Misschien kan het efficienter (ben geen heel ervaren VBA gebruiker), maar onderstaande werkt in elk geval tot een max van 65000 regels en uitgaande van een document dat exact op dezelfde manier is opgemaakt.

Sub Sorteren()
'

'
    Application.ScreenUpdating = False
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C5").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]<>0,RC[-1],IF(RC[1]<>0,R[-1]C[-1],""""))"
    Selection.AutoFill Destination:=Range("C5:C65000"), Type:=xlFillDefault
     Range("C3").Select
    ActiveCell.FormulaR1C1 = "nr"
    Columns("C:C").Select
    Selection.Copy
    Columns("C:C").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B:B").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Rows("4:4").Select
    Selection.Delete Shift:=xlUp
    Range("B3:F3").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Blad1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Blad1").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "B3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Blad1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.ScreenUpdating = True
End Sub

 

[jansm]

hij werkt Erik, maar dan ben ik wel mijn opmaak kwijt. Ik bedoel de lege regels die de scheiding tussen single-koppels en koppels-koppels.

 

[Leotaxi]

met behoud lege rijen


mvg
Leo

 

[HSV]

Iets eenvoudiger geschreven.

Sub hsv()
 With Sheets("blad1")
  .Range("B5:B" & .Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(4) = "=R[-1]C"
  .Cells(5, 2).CurrentRegion.Sort .Range("b5")
  .Columns(3).SpecialCells(4).Offset(, -1).Clearcontents
 End With
End Sub

 

[VenA]

Blijkbaar gisteren deze post bekeken en er wat 'lange' code voor gemaakt en niet geplaatst. Doe ik toch maar aangezien de uitkomst net iets anders is.

Sub VenA()
Application.ScreenUpdating = False
Dim ar, j As Long
With Sheets("Blad1").Cells(3, 2).Resize(Cells(Rows.Count, 3).End(xlUp).Row - 1, 6)
 ar = .Value
 For j = 2 To UBound(ar) - 1
    If ar(j, 1) = "" And ar(j, 2) = "" Then
        ar(j, 6) = ar(j + 1, 1) & "_" & Format(j, "00000")
      Else
        If ar(j, 1) = "" Then ar(j, 6) = ar(j - 1, 1) & "_" & Format(j, "00000") Else ar(j, 6) = ar(j, 1) & "_" & Format(j, "00000")
    End If
 Next j
 .Value = ar
 .Sort [G3], , , , , , , True
 .Columns(6).ClearContents
End With
End Sub

Kleine aantekening: In kolom G moeten geen gegevens staan.

 

[jansm]

Heren allemaal bedankt.
Ik ga de code van Harry HSV gebruiken, die is het simpelst maar heeft een foutje. De laatste in de rij van ongesorteerde data wordt op de juiste plaats gezet, echter, deze wordt niet van de volgende gescheiden door een lege regel. Getest op mijn eigen lijst blijkt dat er nog dubbele single's en koppels tussen zitten. Zou het mogelijk zijn om in de code iets op te nemen die de dubbelen verwijderd? Ik heb het test bestandje opgenomen met een dubbele single en een dubbel koppel.

Bekijk bijlage Sorteer_2.xlsm

Leo, de code werkt goed, zonder fouten.
VenA, de code sorteert niet op nr

 

[Leotaxi]

zonder dubbele

Sub test()
Application.ScreenUpdating = False
lr = Range("C" & Rows.Count).End(xlUp).Row
    For x = lr To 5 Step -1
        If Range("B" & x) = vbNullString And Range("C" & x) <> vbNullString Then Range("B" & x) = Range("B" & x - 1)
    Next
    With Range("B5", "F" & lr)
        .Sort ([B5])
    End With
    For x = lr To 6 Step -1
        If Range("B" & x) <> vbNullString And Range("B" & x) <> Range("B" & x - 1) Then Range("B" & x).EntireRow.Insert
    Next
    For x = Range("B" & Rows.Count).End(xlUp).Row To 6 Step -1
        If Range("B" & x) <> vbNullString Then
            If Range("B" & x) & Range("C" & x) = Range("B" & x - 1) & Range("C" & x - 1) Or Range("B" & x) & Range("C" & x) = Range("B" & x - 2) & Range("C" & x - 2) Then
                Range("B" & x).EntireRow.Delete
            End If
        End If
    Next
Application.ScreenUpdating = True
End Sub

mvg
Leo

 

[jansm]

hij werkt LEO, doet precies wat hij doen moet. Bedankt!

 

[HSV]

Ondanks opgelost.

Iets minder lussen, ± 3x sneller (zeker aantrekkelijk bij meer data dan in het voorbeeldje).

Sub hsv()
Dim x As Long
Application.ScreenUpdating = False
 With Sheets("blad1")
   .Range("b5:b" & .Cells(Rows.Count, 3).End(xlUp).Row).SpecialCells(4) = "=R[-1]C"
   .Cells(Rows.Count, 2).End(xlUp).Offset(1) = "=R[-1]C"
   .Range("b5").CurrentRegion.Sort .[b5]
   .Range("c5:c" & .Cells(Rows.Count, 3).End(xlUp).Row + 1).SpecialCells(4).Offset(, -1).ClearContents
      For x = .Cells(Rows.Count, 2).End(xlUp).Row To 6 Step -1
        If .Cells(x, 2) <> vbNullString Then
            If .Cells(x, 2) & .Cells(x, 3) = .Cells(x - 3, 2) & .Cells(x - 3, 3) Or .Cells(x, 2) & .Cells(x, 3) = .Cells(x - 2, 2) & .Cells(x - 2, 3) Then
                .Cells(x, 2).Resize(2).EntireRow.Delete
            End If
        End If
     Next x
 End With
End Sub

 

[jansm]

Dank Harry, doet het ook!
Ik ga nog een stapje verder en wil de tabel sorteren op bijv Geb. datum. Nu is de oorspronkelijke datum volgens mij in tekst-formaat. Die probeer ik met de code in module 3 om te zetten naar DMJ. Hij wordt nu voor de duidelijkheid weggeschreven in [A]. Maar dat gaat niet naar wens. Volgens mij worden maar 2 cellen omgezet.
Mod 1: code Harry
Mod 2: code Leo (iets aangepast door mij)
Mod 3: Tekst2Date (poging van mij zelf)

Volgorde van proces: mod 1 of 2, dan 3 en vervolgens sorteren op [A]. Ik heb in een blad Bck_Blad1 toegevoegd om de startsituatie terug te kunnen zetten naar Blad1.
Hebben jullie nog zin/tijd??!! We maken er een wedstrijdje van
Bekijk bijlage Sorteer_3.xlsm