• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

combobox in formulier

Status
Niet open voor verdere reacties.
Het is dan wel weer een beetje jammer dat er in de code niets te vinden is hoe je de gegevens samenvat.

Met twee extra kolommen in blad 'Namenlijst' en een extra knop in het formulier kom je daar waar je naar op zoek bent.

Code voor het maken van de lijst met namen

Code: 
Sub VenA()
With Sheets("Namenlijst")
    .Cells(1).CurrentRegion.Offset(1).ClearContents
    For Each sh In Sheets
        If sh.Name <> "Namenlijst" Then
            ar = sh.Cells(2, 1).CurrentRegion.Offset(4).Resize(, 4)
            ReDim ar1(1 To UBound(ar) - 4, 1 To 5)
            For j = 1 To UBound(ar) - 4
                ar1(j, 1) = ar(j, 1)
                ar1(j, 2) = ar(j, 4)
                ar1(j, 3) = ar(j, 3)
                ar1(j, 4) = sh.Name
                ar1(j, 5) = j + 5
            Next j
            .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), UBound(ar1, 2)) = ar1
        End If
    Next sh
End With
End Sub

Code om naar de juiste tab en rij te gaan
Code: 
Private Sub CommandButton1_Click()
    If cboOpzoeken <> "" Then
        Application.Goto Sheets(cboOpzoeken.Column(3)).Cells(cboOpzoeken.Column(4), 1)
        Unload Me
    End If
End Sub
 

Bijlagen

  • Scallebe.xlsb
    161,9 KB · Weergaven: 27
VenA

Zal ik zeker uittesten. Bedankt. Waar plaats ik jou code voor de namenlijst? In this Workbook in de sub Open?

Dit is de code die mijn 5 sheets samenvat. De Excelsheet die gebruikt wordt door de medewerkers staat in "Share-modus". (Is belangrijk... Sommige codes werken niet in share, daarom wordt die eerst uitgeschakeld en op het einde weer ingeschakeld.


Code: 
Private Sub Samenvatting_Click()

' Maakt de sheet Exclusive

    If ActiveWorkbook.MultiUserEditing Then
        Application.DisplayAlerts = False
        ActiveWorkbook.ExclusiveAccess
        Application.DisplayAlerts = True
    End If

' Delete de oude lijst en voegt nieuwe lijnen in

    Sheets("Alle CCF").Select
        Rows("7:" & Range("BM1") + 3).Select
        Selection.Delete Shift:=xlUp
        Range("A1").Select
        Application.Goto Reference:="R7C1:R400C1"
        Selection.RowHeight = 20
        Range("A1").Select

' Verzamelt alle sheets met een update van de formules

    Application.ScreenUpdating = False
    SheetNames = Array("Apothekers", "Kinesisten", "MedGen", "Tandartsen", "Specialisten")
 
    With Sheets("Alle CCF")
        .Range(.Range("CZ6"), .Cells(.Rows.Count, 1).End(xlUp)).ClearContents
    End With
 
    For i = LBound(SheetNames) To UBound(SheetNames)
        With Sheets(SheetNames(i))
            .Range(.Range("CZ6"), .Cells(.UsedRange.Rows.Count, 1)).Copy Sheets("Alle CCF").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End With
    Next i
    Application.ScreenUpdating = True
    Range("A1000000").End(xlUp).Offset(2).End(xlToRight).Select

' Update alle formules

        ActiveCell = "=SUM(R6C:R[-2]C)"
        ActiveCell.Offset(, 1).Select
    For keer = 1 To 4
        ActiveCell = "=(SUMIF(R6C19:R[-2]C19,""UW"",R6C:R[-2]C)+(SUMIF(R6C19:R[-2]C19,""WMU"",R6C:R[-2]C)))"
        ActiveCell.Offset(1).Select
        ActiveCell = "=(SUMIF(R6C19:R[-3]C19,""WM"",R6C:R[-3]C)+(SUMIF(R6C19:R[-3]C19,""WJ"",R6C:R[-3]C)))"
        ActiveCell.Offset(-1, 1).Select
        ActiveCell = "=SUM(R6C:R[-2]C)"
        ActiveCell.Offset(, 1).Select
        ActiveCell = "=(SUMIF(R6C19:R[-2]C19,""UW"",R6C:R[-2]C)+(SUMIF(R6C19:R[-2]C19,""WMU"",R6C:R[-2]C)))"
        ActiveCell.Offset(1).Select
        ActiveCell = "=(SUMIF(R6C19:R[-3]C19,""WM"",R6C:R[-3]C)+(SUMIF(R6C19:R[-3]C19,""WJ"",R6C:R[-3]C)))"
        ActiveCell.Offset(-1, 1).Select
        ActiveCell = "=SUM(R6C:R[-2]C)"
        ActiveCell.Offset(, 1).Select
        ActiveCell = "=(SUMIF(R6C19:R[-2]C19,""UW"",R6C:R[-2]C)+(SUMIF(R6C19:R[-2]C19,""WMU"",R6C:R[-2]C)))"
        ActiveCell.Offset(1).Select
        ActiveCell = "=(SUMIF(R6C19:R[-3]C19,""WM"",R6C:R[-3]C)+(SUMIF(R6C19:R[-3]C19,""WJ"",R6C:R[-3]C)))"
        ActiveCell.Offset(-1, 1).Select
        ActiveCell = "=SUM(R6C:R[-2]C)"
        ActiveCell.Offset(, 2).Select
    Next keer
 
        ActiveCell.Offset(, -1).Select
        ActiveCell = "=(SUMIF(R6C19:R[-2]C19,""UW"",R6C:R[-2]C)+(SUMIF(R6C19:R[-2]C19,""WMU"",R6C:R[-2]C55)))"
        ActiveCell.Offset(1).Select
        ActiveCell = "=(SUMIF(R6C19:R[-3]C19,""WM"",R6C:R[-3]C)+(SUMIF(R6C19:R[-3]C19,""WJ"",R6C:R[-3]C)))"
        ActiveCell.Offset(-1, 3).Select
        ActiveCell = "=SUM(R6C:R[-2]C)"
        ActiveCell.Offset(, 1).Select
        ActiveCell = "=SUM(R6C:R[-2]C)"
        ActiveCell.Offset(, 1).Select
        ActiveCell = "=SUM(R6C:R[-2]C)"
        ActiveCell.Offset(, 1).Select
        ActiveCell = "=SUM(R6C:R[-2]C)"
        ActiveCell.Offset(4, -3).Select
        ActiveCell = "=SUMIF(R6C5:R[-6]C5,RC[-1],R6C:R[-6]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUMIF(R6C5:R[-7]C5,RC[-1],R6C:R[-7]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUMIF(R6C5:R[-8]C5,RC[-1],R6C:R[-8]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUM(R[-3]C:R[-1]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=((R[-1]C)-(R[-8]C))"
        ActiveCell.Offset(-4, 1).Select
        ActiveCell = "=SUMIF(R6C5:R[-6]C5,RC[-2],R6C:R[-6]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUMIF(R6C5:R[-7]C5,RC[-2],R6C:R[-7]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUMIF(R6C5:R[-8]C5,RC[-2],R6C:R[-8]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUM(R[-3]C:R[-1]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=((R[-1]C)-(R[-8]C))"
        ActiveCell.Offset(-4, 1).Select
        ActiveCell = "=SUMIF(R6C5:R[-6]C5,RC[-3],R6C:R[-6]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUMIF(R6C5:R[-7]C5,RC[-3],R6C:R[-7]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUMIF(R6C5:R[-8]C5,RC[-3],R6C:R[-8]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUM(R[-4]C:R[-1]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=((R[-1]C)-(R[-8]C))"
        ActiveCell.Offset(-4, 1).Select
        ActiveCell = "=SUMIF(R6C5:R[-6]C5,RC[-4],R6C:R[-6]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUMIF(R6C5:R[-7]C5,RC[-4],R6C:R[-7]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUMIF(R6C5:R[-8]C5,RC[-4],R6C:R[-8]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=SUM(R[-4]C:R[-1]C)"
        ActiveCell.Offset(1).Select
        ActiveCell = "=((R[-1]C)-(R[-8]C))"
        ActiveCell.Offset(-5).Select
        Selection.Rows.AutoFit
        Columns("A:BL").Select
        Selection.Columns.AutoFit
        Columns("BJ:BK").Select
        Selection.Columns.AutoFit
        Range("BM1") = "=COUNTA(R6C1:R1000000C1)+5"
        Range("BN1") = "=""$A$6:$A$""&RC[-1]"
        Range("B2") = "=IF(ISERROR(SUMPRODUCT(1/COUNTIF(INDIRECT(R[-1]C[+64]),INDIRECT(R[-1]C[+64])))),0,(SUMPRODUCT(1/COUNTIF(INDIRECT(R[-1]C[+64]),INDIRECT(R[-1]C[+64])))))"
        Columns("BM:CZ").Select
        Selection.EntireColumn.Hidden = True
        ActiveWorkbook.Worksheets("Alle CCF").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Alle CCF").Sort.SortFields.Add Key:=Range("A5"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
         With ActiveWorkbook.Worksheets("Alle CCF").Sort
            .SetRange Range("A6:BK" & Range("BM1"))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Range("A3").Select
        
    Sheets("DT Alle CCF").Select
'    Range("A4").Select
    Regels = [BM1]
    ActiveSheet.PivotTables("Draaitabel1").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Alle CCF!R5C1:R" & Regels & "C63" _
        , Version:=xlPivotTableVersion14)
    ActiveWorkbook.RefreshAll
    Sheets("Alle CCF").Select
    Range("A3").Select
            
If Not ActiveWorkbook.MultiUserEditing Then
       Application.DisplayAlerts = False
       ActiveWorkbook.SaveAs ActiveWorkbook.Name, accessmode:=xlShared
       Application.DisplayAlerts = True
End If

End Sub

De opbouw van deze code zal heel waarschijnlijk niet helemaal volgens de regels van het spel zijn ... :confused:

Jullie hebben een groot deel bijgedragen aan de opbouw. :thumb:

En ik heb er zelf nog wat codes bijgevoegd (die ik gecreëerd met een macro-opname) :confused:

Greetz
 
Laatst bewerkt:
VenA

De code voor namenlijst werkt maar ik krijg een error : Fout 9 tijdens uitvoering: Het subscript valt buiten het bereik.

Ik vermoed dat dit te maken heeft dat de code alle sheets afgaat om de gegevens op te halen.

Ik moet zeggen dat er in totaal 18 sheets zijn. :confused:

Tenzij je kan bepalen in welke sheets hij de gegevens moet gaan halen. (Apothekers, Kinesisten, MedGen, Tandartsen en Specialisten)

De voorbeelden die ik meestuur zijn beperkt. (vanwege de grootte)

Is er misschien een mogelijkheid om de volledig file ergens te plaatsen zodat je het volledig plaatje eens kan bekijken? (= 2,3 MB)

Dropbox, of iets anders...

Bedankt


Greetz

Pascal
 
Laatst bewerkt:
Wat je met de code in #22 allemaal aan het doen bent weet ik niet. Het heeft volgens mij ook weinig met de vraag te maken. Sheets("Alle CCF") kom ik in het voorbeeld bestand niet tegen. Om de namenlijst te vullen uit een beperkt aantal tabbladen kan je zoiets gebruiken.

Code: 
Sub VenA()
With Sheets("Namenlijst")
    .Cells(1).CurrentRegion.Offset(1).ClearContents
    For Each sh In Sheets(Array("Apothekers", "Kinesisten"))
        ar = sh.Cells(2, 1).CurrentRegion.Offset(4).Resize(, 4)
        ReDim ar1(1 To UBound(ar) - 4, 1 To 5)
        For j = 1 To UBound(ar) - 4
            ar1(j, 1) = ar(j, 1)
            ar1(j, 2) = ar(j, 4)
            ar1(j, 3) = ar(j, 3)
            ar1(j, 4) = sh.Name
            ar1(j, 5) = j + 5
        Next j
        .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), UBound(ar1, 2)) = ar1
    Next sh
End With
End Sub
Waarbij je de Array moet aanvullen met de bladen die je wil gebruiken. Je kan de code ook gebruiken in ThisWorkbook.

Grote bestanden zijn normaal gesproken niet nodig om te plaatsen omdat het erom gaat dat je de aangereikte oplossing(en) moet proberen te begrijpen en dan toe te passen in jouw eigen bestand. Je kan het bestand verkleinen door de tabs die niets met de vraag te maken hebben eruit te halen. En het bestand vervolgens opslaan als .XLSB Dan kan je tot 1 MB uploaden.
 
VenA,

De code in #22 is de code van het originele bestand om een samenvatting te maken van de 5 belangrijke sheets en is dus ook niet van toepassing voor de meegestuurde voorbeelden.

Ik dacht dat je die code gevraagd had in #21. Misverstand :confused:

De meegestuurde voorbeelden heb ik inderdaad beperkt. Tabs verwijderd, gegevens verwijderd, ... Het originele bestand is te groot om als bijlage mee te sturen.

Ik zal het bestand proberen te reduceren en het hier plaatsen.



Bedankt alvast voor de oplossingen die je meegegeven hebt. :thumb:


Greetz


Pascal
 
Laatst bewerkt:
Wees slim plaats geen emailadres in een post: verwijder hem uit de laatste.
 
VenA,

Ik jouw code geplaatst en het werkt perfect. :thumb:

Code: 
Sub VenA()
With Sheets("Namenlijst")
    .Cells(1).CurrentRegion.Offset(1).ClearContents
    For Each sh In Sheets(Array("Apothekers", "Kinesisten", "MedGen", "Tandartsen", "Specialisten"))
        ar = sh.Cells(2, 1).CurrentRegion.Offset(4).Resize(, 4)
        ReDim ar1(1 To UBound(ar) - 4, 1 To 5)
        For j = 1 To UBound(ar) - 4
            ar1(j, 1) = ar(j, 1)
            ar1(j, 2) = ar(j, 4)
            ar1(j, 3) = ar(j, 3)
            ar1(j, 4) = sh.Name
            ar1(j, 5) = j + 5
        Next j
        .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), UBound(ar1, 2)) = ar1
    Next sh
End With
End Sub

Nu zou ik de lijst in Sheet Namenlijst alfabetisch willen sorteren en opnieuw de range bepalen met de naam "Naamlijst"

Ik heb daarvoor de volgende code bijgeplaatst :

Je zal in de code een verwijzing zien naar "F1" voor het bepalen van de Range.
Dit klopt omdat ik ook een code heb bijgevoegd om hem het aantal namen te tellen en zo de range te kunnen bepalen met volgende code :

Code: 
ActiveWorkbook.Worksheets("Namenlijst").Range("F1") = "=COUNTA(R6C1:R1000000C1)+4"


de code voor Range bepalen :

Code: 
    ActiveWorkbook.Worksheets("Namenlijst").Names.Add Name:="Naamlijst", RefersToR1C1:=Range(Cells(2, 1), Cells(Range("F1") + 1, 4))

De code voor Sorteren :

Code: 
    Range("A2:E" & Range("F1") + 1).Select
    ActiveWorkbook.Worksheets("Namenlijst").sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Namenlijst").sort.SortFields.Add Key:=Range("A2") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Namenlijst").sort
        .SetRange Range("A2:E" & Range("F1") + 1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Voor de een of andere reden wordt de range bepaald in een andere sheet en niet de sheet Namenlijst

Nu moet ik wel zeggen dat de sheet Namenlijst verborgen is maar de volledige code werkt behalve het bepalen van de Range.

Hoe komt dat en hoe kan dit opgelost worden?

Dit is de volledige code :

Code: 
Sub VenA()
With Sheets("Namenlijst")
    .Cells(1).CurrentRegion.Offset(1).ClearContents
    For Each sh In Sheets(Array("Apothekers", "Kinesisten", "MedGen", "Tandartsen", "specialisten"))
        ar = sh.Cells(2, 1).CurrentRegion.Offset(4).Resize(, 4)
        ReDim ar1(1 To UBound(ar) - 4, 1 To 5)
        For j = 1 To UBound(ar) - 4
            ar1(j, 1) = ar(j, 1)
            ar1(j, 2) = ar(j, 4)
            ar1(j, 3) = ar(j, 3)
            ar1(j, 4) = sh.Name
            ar1(j, 5) = j + 5
        Next j
        .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), UBound(ar1, 2)) = ar1
    Next sh
End With

'Telt het aantal namen

    ActiveWorkbook.Worksheets("Namenlijst").Range("F1") = "=COUNTA(R6C1:R1000000C1)+4"

'Bepaald de Range

    ActiveWorkbook.Worksheets("Namenlijst").Names.Add Name:="Naamlijst", RefersToR1C1:=Range(Cells(2, 1), Cells(Range("F1") + 1, 4))

'Sorteert de namen
    Range("A2:E" & Range("F1") + 1).Select
    ActiveWorkbook.Worksheets("Namenlijst").sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Namenlijst").sort.SortFields.Add Key:=Range("A2") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Namenlijst").sort
        .SetRange Range("A2:E" & Range("F1") + 1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Bedankt

Greetz

Pascal
 
Laatst bewerkt:
Wat wil je in F1 hebben en waarom? Om de namenlijst te sorteren op Naam en Voornaam kan je dit gebruiken. Natuurlijk nog steeds obv van een eerder voorbeeld bestandje.
Code: 
Sub VenA()
With Sheets("Namenlijst")
    .Cells(1).CurrentRegion.Offset(1).ClearContents
    For Each sh In Sheets(Array("Apothekers", "Kinesisten"))
        ar = sh.Cells(2, 1).CurrentRegion.Offset(4).Resize(, 4)
        ReDim ar1(1 To UBound(ar) - 4, 1 To 5)
        For j = 1 To UBound(ar) - 4
            ar1(j, 1) = ar(j, 1)
            ar1(j, 2) = ar(j, 4)
            ar1(j, 3) = ar(j, 3)
            ar1(j, 4) = sh.Name
            ar1(j, 5) = j + 5
        Next j
        .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), UBound(ar1, 2)) = ar1
    Next sh
   .Cells(1).CurrentRegion.Sort [A1], , [B1], , , , , 1
End With
End Sub
 
Laatst bewerkt:
VenA

Ik tel het aantal namen en zet het resultaat in F1.

Dat resultaat gebruik ik dan verder in de code om de hele lijst te selecteren en de "naam definiëren" actie uit te voeren : zijnde Naamlijst, dat ik dan later gebruik in de RowSource van mijn combobox van mijn formulier.

Je kan dit zien in de code voor : Range bepalen in #27

Het aantal personen in de 5 sheets kan variëren. Er komen er bij of er worden er verwijderd. Dus laat ik hem altijd opnieuw tellen en de naam definiëren aanpassen.


Greetz
 
Laatst bewerkt:
Ik ben echt een vba-dummie.
Soms probeer ik code te creëren door een macro op te nemen. Ik weet dat dat niet ideaal is en dat het meestal eenvoudiger kan met vba. Bv dat sorteren. Ik krijg via een macro een regel of 5,6 en dat werkt en jij lost het dan op met 1 regel.
 
VenA,

Eigenlijk creëer ik die namenlijst om de RowSource van de combo box in het Form frmOpzoeken te kunnen bepalen.

Vermoedelijk is dat overbodig en kan het rechtstreeks gecodeerd worden in de combo box maar ik weet niet hoe.

De namen zijn beschikbaar in de 5 sheets. Ik zou ze in de combo box van het frmOpzoeken willen zien alfabetisch gerangschikt.

Ik heb de volledige werkbook in bijlage gezet met de belangrijkste sheets. Ik heb wel het een en ander verwijderd om de file-grootte te reduceren.

Je zal dus diverse codes zien die niet meer aan een button zijn verbonden bv...

De code voor het creëren van de namenlijst vind je in ThisWorkBook.

Bekijk bijlage Prestaties CCF.xlsb


Greetz

Pascal
 
Laatst bewerkt:
Maak gebruik van combobox1.list ipv Rowsource.
Van onderstaande regel moet je de rode punten nog toevoegen in Thisworkbook.
Code: 
.Cells(1).CurrentRegion.Sort [COLOR=#ff0000][SIZE=5].[/SIZE][/COLOR][A2], , [SIZE=5][COLOR=#ff0000].[/COLOR][/SIZE][B2], , , , , 1
 
Voor de duidelijkheid, die punten mogen ook zwart zijn :p
 
HSV,

Wat bedoel je daar mee? : Maak gebruik van combobox1.list ipv Rowsource.

De combobox moet toch ergens zijn gegevens halen?

Greetz
 
Ik heb dit gevonden en denk dat dit voor mij van toepassing is :

Code: 
ComboBox1.List = Sheets(1).Cells(1,1).rResize(10,10).Value

en ik denk dat ik het voor mij zo moet aanpassen :

Code: 
cboOpzoeken.List = Sheets("Namenlijst").Cells(4,2).rResize(10,10).Value

Ik zou de kolommen A - B - C - D willen zie in mij Combobox.


Please correct me if I'm wrong... :confused:


En waar plaats ik de code?

Greetz
 
Laatst bewerkt:
Verwijder de eerste lege regel van blad 'Namenlijst'.
Verwijder 'Rowsource' in de eigenschappen van 'cboOpzoeken'.

Meer heb je niet nodig dan dit om de combo te vullen.

Code: 
Private Sub Userform_Initialize()
cboOpzoeken.List = Sheets("namenlijst").Cells(1).CurrentRegion.Value
End Sub
 
HSV

Om de een of andere reden begint de lijst in cel A2 en niet in A1. Voorheen was dit juist omdat ik hem liet tellen in E1 en Row 1 bleef verder leeg. Maar nu is dat niet meer nodig.

Nu mag de lijst in cel A1 beginnen.

Ik kan in de code niet terugvinden waar dat bepaald wordt.

hier is de code

Code: 
Private Sub Workbook_Open()
    
With Sheets("Namenlijst")
    .Cells(1).CurrentRegion.Offset(1).ClearContents
    For Each sh In Sheets(Array("Apothekers", "Kinesisten", "MedGen", "Tandartsen", "Specialisten"))
        ar = sh.Cells(2, 1).CurrentRegion.Offset(4).Resize(, 4)
        ReDim ar1(1 To UBound(ar) - 4, 1 To 5)
        For j = 1 To UBound(ar) - 4
            ar1(j, 1) = ar(j, 1)
            ar1(j, 2) = ar(j, 4)
            ar1(j, 3) = ar(j, 3)
            ar1(j, 4) = sh.Name
            ar1(j, 5) = j + 5
        Next j
        .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1), UBound(ar1, 2)) = ar1
    Next sh
     .Cells(1).CurrentRegion.Sort .[A1], , .[B1], , , , , 1
End With

End Sub
 
Laatst bewerkt:
Die moet je plaatsen in het bewuste formulier.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan