Gecombineerde lijst maken, duplicaten verwijderen

[Unplugged]

Ik ben bezig met een lijst waarop (met het oog op de diensten in onze kerk) staan.
- alle zondagen
- alle feestdagen die jaarlijks variëren (zoals Pasen en Pinksteren)
- alle feestdagen met een vaste datum (zoals Kerst)
- alle feestdagen op een bepaalde weekdag (zoals bid- en dankdag)

Via formules kan ik al deze dagen bepalen. Ze staan in bijgevoegde Excel op vier werkbladen.

Nu wil ik een gecombineerde lijst hiervan maken. Voorwaarde daarbij is dat er geen doublures op voorkomen. Dus zondag 9 april 2023 is ook 1e Paasdag. Op de gecombineerde lijst mag deze maar één keer voorkomen, met de aanduiding '1e Paasdag'. Etcetera. Aanvullende voorwaarde is bovendien dat de gecombineerde lijst met data geen formules meer bevat, maar de 'harde' datum.

Is dit te automatiseren of blijft het gewoon handwerk (handmatig kopiëren naar een vijfde blad via 'Waarden plakken', sorteren, en vervolgens handmatig de duplicaten verwijderen)?

 

[Haije]

Unplugged,

zie bijlage. In deze bijlage wort d.m.v. een druk op de knop op het laatste blad de lijst samengesteld.
NB: wel macro's toestaan.

 

[Unplugged]

Heel fijn! Bedankt hiervoor. Moet me toch eens gaan verdiepen in VBA.

 

[AD1957]

nog een optie.

Sub Combineer()
Dim sh As Worksheet

Range("B1").CurrentRegion.Offset(1).ClearContents


For Each sh In ThisWorkbook.Sheets
i = Sheets("Gecombineerde lijst").Range("B" & Rows.Count).End(xlUp).Row + 1
       
    If sh.Name <> "Gecombineerde lijst" Then
        j = sh.Range("B" & Rows.Count).End(xlUp).Row
        sh.Range("B2:c" & j).Copy
        Sheets("Gecombineerde lijst").Range("B" & i).PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
    End If
Next


i = Range("B" & Rows.Count).End(xlUp).Row
Range("B2:C" & i).Sort Range("B2")
For i = 3 To i
    If Cells(i, 2) = Cells(i - 1, 2) Then Cells(i - 1, 2).EntireRow.Delete
Next
End Sub

update: zie nu dat de code niet correct werkt

 

[AD1957]

deze lijkt me wel goed.

Dim sh As Worksheet

Range("B1").CurrentRegion.Offset(1).ClearContents


For Each sh In ThisWorkbook.Sheets
i = Sheets("Gecombineerde lijst").Range("B" & Rows.Count).End(xlUp).Row + 1
       
    If sh.Name <> "Gecombineerde lijst" Then
        j = sh.Range("B" & Rows.Count).End(xlUp).Row
        sh.Range("B2:c" & j).Copy
        Sheets("Gecombineerde lijst").Range("B" & i).PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
    End If
Next


j = Range("B" & Rows.Count).End(xlUp).Row
Range("B2:C" & j).Sort Range("B2")
For i = 3 To j
    If Cells(i, 2) = Cells(i - 1, 2) Then Cells(i - 1, 2).EntireRow.Delete
Next

 

[JEC.]

Of direct met een dictionary

Sub jec()
 Dim ar, dic, i As Long, j As Long
 Set dic = CreateObject("scripting.dictionary")
 
 For j = Sheets.Count - 1 To 1 Step -1
    ar = Sheets(j).Range("B1").CurrentRegion.Resize(, 3).Value2
    For i = 2 To UBound(ar)
       If Not dic.exists(ar(i, 2)) Then dic.Item(ar(i, 2)) = Array(ar(i, 2), ar(i, 3))
    Next
 Next
 With Sheets("Gecombineerde lijst")
    .Cells(2, 1).Resize(dic.Count, 2) = Application.Index(dic.items, 0, 0)
    .Cells(2, 1).CurrentRegion.Sort .Cells(2, 1)
 End With
End Sub