VBA-code: specifieke selectie uit gegevensbereik kopiëren naar verschillende tabs

[Grijsbert]

Goedemorgen,

Ik ben op zoek naar een VBA code om een specifieke selectie uit gegevensbereik kopiëren naar verschillende tabs.
In tab "cliëntgegevens" heb ik een macrobutton aangemaakt, zodat voor elke cliëntnaam automatisch een tabblad aangemaakt wordt met alle aanwezige cliëntgegevens.

Het idee is om in een later stadium in MS Word met afdruk samenvoegen snel facturen te kunnen draaien.

Daarvoor is nodig dat de informatie uit de tab "Aanwezigheidsregistratie" mbv VBA-code onder de juiste tab in kolommen P(dagdelen) en Q(bijbehorende datum) geplakt wordt.
Het lukt me maar niet om een code te schrijven die dit op een slimme manier doet.

Het is enigszins mogelijk om het kunstje voor 1 cliënt uit te halen, maar ik loop dan tegen verschillende beperkingen aan:
- er worden dubbele waardes gekopieerd en geplakt
- gekopieerde cellen krijg ik niet op de juiste plaats
- enz.

Het liefst wil ik dat door op de knop te drukken zowel tabbladen aangemaakt worden(indien van toepassing) als, aanwezigheidsinformatie juist geadresseerd wordt.

Ik ben benieuwd naar jullie suggesties!Bekijk bijlage voorbeeld.zip

 

[VenA]

Probeer het zo eens

Sub VenA()
Dim ar, j As Long
With Sheets("Cliëntgegevens")
    .[g1] = "Cliënt"
    ar = .ListObjects(1).DataBodyRange.Columns(1)
    For j = 1 To UBound(ar)
        If IsError(Evaluate("'" & ar(j, 1) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = ar(j, 1) Else Sheets(ar(j, 1)).Cells.Clear
        .[g2] = ar(j, 1)
        .ListObjects(1).Range.AdvancedFilter xlFilterCopy, .Range("G1:G2"), Sheets(ar(j, 1)).Range("A1")
        With Sheets("Aanwezigheidsregistratie").ListObjects(1)
            .Range.AutoFilter 2, ar(j, 1)
            .Range.Offset(1, 2).Resize(, 2).Copy Sheets(ar(j, 1)).[p2]
            .Range.AutoFilter 2
        End With
    Next j
    .[g1:g2].Clear
End With
End Sub

 

[Grijsbert]

Brilliant! :thumb:

Nog een vraagje, hoe kan ik ervoor zorgen dat in (een nieuw toegevoegde kolom R) het bedrag per dagdeel automatisch bepaald kan worden?
Dat bedrag wordt berekend door kolom P * kolom G te doen.
Dus een ingevuld tarief van €1000 geeft bij 2 dagdelen = €1000*2=€2000

Zo ontstaat in het tabblad een opsomming van dagdelen/datums/bedragen.

En ik weet niet of dat ook mogelijk is, maar onderaan kolom R toevoegen de som van alle specifieke bedragen.
In kolom Q dan het woordje "Totaal:" voorafgaand aan de Som.

Ben weer benieuwd!

 

[VenA]

Zoiets?

Sub VenA()
Dim ar, ar1, j As Long, jj As Long, t As Double
With Sheets("Cliëntgegevens")
    .[g1] = "Cliënt"
    ar = .ListObjects(1).DataBodyRange.Columns(1)
    For j = 1 To UBound(ar)
        If IsError(Evaluate("'" & ar(j, 1) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = ar(j, 1) Else Sheets(ar(j, 1)).Cells.Clear
        .[G2] = ar(j, 1)
        .ListObjects(1).Range.AdvancedFilter xlFilterCopy, .Range("G1:G2"), Sheets(ar(j, 1)).Range("A1")
        With Sheets("Aanwezigheidsregistratie").ListObjects(1)
            .Range.AutoFilter 2, ar(j, 1)
            .Range.Offset(1, 2).Resize(, 2).Copy Sheets(ar(j, 1)).[p2]
            .Range.AutoFilter 2
        End With
        With Sheets(ar(j, 1))
            If .Cells(Rows.Count, 16).End(xlUp).Row > 1 Then
                ar1 = .Columns(16).SpecialCells(2, 1)
                t = 0
                For jj = 1 To UBound(ar1)
                    ar1(jj, 1) = ar1(jj, 1) * .[G2]
                    t = t + ar1(jj, 1)
                Next jj
                .[r2].Resize(UBound(ar1)) = ar1
                .[q2].Offset(UBound(ar1)).Resize(, 2) = Array("Totaal", t)
            End If
        End With
    Next j
    .[g1:g2].Clear
End With
End Sub

 

[Grijsbert]

Geeft een error bij: regel: ar1 = .Columns(16).SpecialCells(2, 1)
Fout 1004 tijdens uitvoering:

Er zijn geen cellen gevonden.

Ik heb e.e.a overigens geplakt onder een macrobutton die Private Sub Update_Click() heet.
Ik weet niet of dat nog van invloed is.

 

[VenA]

Deze regel zou dat moeten ondervangen.

If .Cells(Rows.Count, 16).End(xlUp).Row > 1 Then

In het voorbeeldbestand werkt de code.

 

[Grijsbert]

Beste VenA,

Dank heb jouw bestand gebruikt als uitgangspunt.
Werkt nu wel. Mogelijk iets verkeerd gedaan bij knippen en plakken.

Bedankt voor de moeite!

Heb je trouwens ook verstand van afdruk samenvoegen naar Word?
De laatste stap die ik nog moet volbrengen is het automatiseren van het samenstellen van de facturen.

Ik moet dan per cliënt op de factuur opnemen:
_____________________________________________
Maand: augustus

Datum|Dagdelen|Bedrag
---- ---- ----
enz.
Totaal Totaalbedrag
___________________________________________________
Wellicht kan het ook op een andere manier?

Het idee is: 1 druk op de knop en alle facturen worden:
- Samengesteld op basis van een sjabloon
- Opgeslagen in een specifieke map als .pdf
- Toegevoegd aan een nieuwe e-mail die automatisch opent en al een standaard onderwerpregel bevat (factuur naam cliënt maand jaar)

Heb je hier ideeën over?

 

[VenA]

De vraag ging over het verdelen van de gegevens over verschillende tabjes. (wat ik bijna altijd een slecht idee vind)

Heb je hier ideeën over?

Mijn idee is dat het onzinnig omslachtig is.
Je hebt nu twee tabellen met alle data die je nodig hebt. Hoewel ik weinig weet van VBA in Word lijkt het mij ook wel mogelijk om op een soortgelijke manier de data naar Word te krijgen. Blijft nog de vraag waarom eerst naar Word en dan een .pdf maken en mailen? Kan je het geheel niet in Excel afhandelen?

Om het een beetje leesbaar te houden kan je er, denk ik, beter even een nieuwe vraag voor openen.

 

[Grijsbert]

Beste VenA,

Je hebt gelijk ik zie nu ook in dat ik beter met minder tabbladen toe kan.
Dus 1: cliëntgegevens
en 2: registratiegegevens.

Vervolgens in Excel een blanco sjabloon op tab 3 en daar een macro op los laten om maandelijks de facturen te draaien m.b.v. de gegevens in tab 1 en 2.

Dank voor de moeite. Iig leerzaam!