Goedemorgen Molly,
Ik heb jouw alternatieve aanpak grondig doorgenomen en mits enkele aanpassingen en toevoegen is dit in principe volledig ok.
Althans toch voor deel 1 (vullen 'arRijen') en deel 3 (wegschrijven naar de werkbladlijsten) van de sub.
Het middelste deel (de juiste gegevens in de naam-arrays plaatsen) is zeker 'ok' voor wat de verwerking 'IDX_G' betreft maar
lijkt voor mij (met mijn beperkte kennis) iets ingewikkelder om aan te passen zodat het kan toegepast worden op de drie verschillende werkbladen.
Ik denk dat hier mijn aanpak met loops (eventueel iets anders opgebouwd dan hoe ik het had gedaan) interessanter is gezien de variatie in het aantal
kolommen dat dient ingelezen te worden bij elk werkblad. Maar zoals ik al zei is mijn veronderstelling gebaseerd op mijn eigen (beperkte) kennis van VBA.
Mogelijks is er door mensen met veel meer kennis (zoals jij oa) wel een simpele aanpassing van de "Select Case"-aanpak mogelijk.
Bij werkblad 'IDX_G' zijn er 4 kolommen met familienamen en 5 kolommen met voornamen.
Bij werkblad 'IDX_H' zijn er 7 kolommen met familienamen en 8 kolommen met voornamen.
Bij werkblad 'IDX_O' zijn er 5 kolommen met familienamen en 6 kolommen met voornamen.
Dit heb ik er nu van gemaakt in zijn geheel waarbij het middelste deel dus enkel van toepassing is op 'IDX_G' :
Sub idx2totdb_p1()
Dim ws As Worksheet, bgnkol As Long, arkol As Long, begin As Long, einde As Long, arRijen, i As Long
Dim k As Long, aantal_f As Long, arfamnm(), vrnaam As Variant, n As Variant, j As Long, aantal_v As Long, arvrnm()
Dim f As Long, fkol As Variant, v As Long, vkol As Variant
Dim ftot As Long, vtot As Long, tekst As Variant
Select Case Application.Caller
Case "g_idx2tdb"
Set ws = Sheets("IDX_G")
bgnkol = 22
arkol = 18
Case "h_idx2tdb"
Set ws = Sheets("IDX_H")
bgnkol = 28
arkol = 24
Case "o_idx2tdb"
Set ws = Sheets("IDX_O")
bgnkol = 25
arkol = 21
End Select
With ws
begin = .Cells(Rows.Count, bgnkol).End(xlUp).Row + 1
einde = .Cells(Rows.Count, 1).End(xlUp).Row
If einde > 1 Then
arRijen = .Cells(begin, 1).Resize(einde + 1 - begin, arkol)
For i = begin To einde
arRijen(i + 1 - begin, arkol) = i
Next i
For i = 1 To einde + 1 - begin
For k = 1 To UBound(arRijen, 2)
Select Case k
Case 9, 12, 14, 16
aantal_f = aantal_f + 1
ReDim Preserve arfamnm(1 To aantal_f)
arfamnm(aantal_f) = arRijen(i, k)
Case 10, 11, 13, 15, 17
vrnaam = arRijen(i, k)
n = Split(vrnaam, " ")
For j = 0 To UBound(n)
aantal_v = aantal_v + 1
ReDim Preserve arvrnm(1 To aantal_v)
arvrnm(aantal_v) = n(j)
Next j
End Select
Next k
Next i
ftot = 0: vtot = 0
With Sheets("famnm-lijst")
For f = 0 To UBound(arfamnm)
On Error Resume Next
fkol = Left(arfamnm(f), 1)
If Application.CountIf(.Columns(fkol), arfamnm(f)) = 0 Then
.Cells(1, fkol).Offset(Application.CountA(.Columns(fkol))).Font.Color = vbRed
.Cells(1, fkol).Offset(Application.CountA(.Columns(fkol))) = arfamnm(f)
ftot = ftot + 1
End If
Next f
.Columns("A:Z").EntireColumn.AutoFit
End With
With Sheets("vrnm-lijst")
For v = 0 To UBound(arvrnm)
On Error Resume Next
vkol = Left(arvrnm(v), 1)
If Application.CountIf(.Columns(vkol), arvrnm(v)) = 0 Then
.Cells(1, vkol).Offset(Application.CountA(.Columns(vkol))).Font.Color = vbRed
.Cells(1, vkol).Offset(Application.CountA(.Columns(vkol))) = arvrnm(v)
vtot = vtot + 1
End If
Next v
.Columns("A:Z").EntireColumn.AutoFit
End With
If ftot > 0 Then tekst = "Er zijn nieuwe familienamen toegevoegd."
If vtot > 0 Then tekst = "Er zijn nieuwe voornamen toegevoegd."
If ftot > 0 And vtot > 0 Then tekst = "Er zijn nieuwe familie- & voornamen toegevoegd."
If tekst <> "" Then
MsgBox tekst
Else
idx2totdb_p2
End If
End If
End With
End Sub
Ik ga het alleszins in de loop van de dag ook zelf blijven bestuderen mbt aanpassen van dat specifiek codeblok.
groetjes,
Bieke