Pietendiploma

[henryvanbeek]

Beste Helpmij,

Ik ben met het volgende bezig. Ik ben bestuurslid van de personeelsvereniging van mijn werk. En Sinterklaas komt ook bij ons 1 keer per jaar langs. Normaal gesproken huurden we voor de kinderen een clown in maar dit jaar zijn we bezig om zelf nog iets in elkaar te knutselen.
We doen dit jaar een aantal spelletjes met het thema 'hoe word je zwarte piet'. Met als slotstuk een heus Pietendiploma.
Nu wil ik dus automatisch de diploma's kunnen maken met een macro. Ik krijg een lijst met namen. En op basis van die lijst wil ik de pagina's opslaan als pdf bestanden. Het liefste onder de naam van het kind. Het opslaan naar pdf heb ik de VBA code al voor gevonden

    ActiveSheet.Shapes.Range(Array("Picture 3")).Select
    Range("A1:O30").Select
    Range("A30").Activate
    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\Harma&Henry\Documents\pietendiploma.pdf", Quality:=xlQualityMinimum _
        , IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _

Maar waar nu pietendiploma staat in de bestandsnaam wil ik dan de naam van het kind zitten. De namenlijst die er nu in zit is een voorbeeld
ik verwacht dat de lijst die ik krijg ongeveer een 110 kinderen bevat.

Dus kort wat ik wil:

1. Naam wijzigen
2. diploma opslaan onder naam kind
3. naam kind wijzigen één cel naar onder
4. weer na punt 2 tot de cel leeg is.


Bekijk bijlage pietendiploma.xlsx

kan iemand me verder helpen?

Groetjes Henry van Beek

 

[alphamax]

Option Explicit

Public Sub Pietendiploma()
    Dim lngRow As Long
    Dim lngRows As Long
    Dim rngDiploma As Range
    Dim strFullName As String
        Set rngDiploma = Worksheets("diploma").Range("A1:O30")
        With Worksheets("namen")
            lngRows = .Range("C" & .Rows.Count).End(xlUp).Row 'vind laatste rij met namen
            If lngRows >= 2 Then 'zijn er namen?
                For lngRow = 2 To lngRows
                    Worksheets("diploma").Range("J5").Value = .Range("C" & lngRow).Value
                    strFullName = "C:\Users\Harma&Henry\Documents\" & CStr(.Range("C" & lngRow).Value) & ".pdf" 'pad samenstellen
                    rngDiploma.ExportAsFixedFormat Type:=xlTypePDF, _
                                                    Filename:=strFullName, _
                                                    Quality:=xlQualityMinimum, _
                                                    IncludeDocProperties:=True, _
                                                    IgnorePrintAreas:=False, _
                                                    OpenAfterPublish:=False
                Next
            End If
        End With
        Set rngDiploma = Nothing
End Sub

let op! speciale leestekens (trema's etc) kunnen problemen opleveren met bestandsnamen
mocht dit het geval zijn laat het dan even weten dan kan de code aangepast worden

 

[henryvanbeek]

beste alphamax,

geen problemen ondervonden de eerst keer. Toen werkte het prima. Alleen nu heb ik wat namen toegevoegd aan de lijst en nu werkt het niet meer.

Groetjes Henry

 

[alphamax]

de code kijkt in kolom c, je moet daar wel de formule doorvoeren
zitten er speciale teken in je namen, sommige mogen van windows niet in de bestandsnaam

 

[HSV]

Het ligt er aan van welk blad je de code laat lopen, daar @alphamax een paar belangrijke punten is vergeten in de code te zetten.
Aangepast (rode punten).

Public Sub Pietendiploma()
    Dim lngRow As Long
    Dim lngRows As Long
    Dim rngDiploma As Range
    Dim strFullName As String
        Set rngDiploma = Worksheets("diploma").Range("A1:O30")
        With Worksheets("namen")
            lngRows = [COLOR="#FF0000"].[/COLOR]Range("C" & Rows.Count).End(xlUp).Row 'vind laatste rij met namen
            If lngRows >= 2 Then 'zijn er namen?
                For lngRow = 2 To lngRows
                    Worksheets("diploma").Range("J5").Value = .Range("C" & lngRow).Value
                    strFullName = "D:\Users\Harma&Henry\Documents\" & CStr([COLOR="#FF0000"].[/COLOR]Range("C" & lngRow).Value) & ".pdf" 'pad samenstellen
                    rngDiploma.ExportAsFixedFormat Type:=xlTypePDF, _
                                                    Filename:=strFullName, _
                                                    Quality:=xlQualityMinimum, _
                                                    IncludeDocProperties:=True, _
                                                    IgnorePrintAreas:=False, _
                                                    OpenAfterPublish:=False
                Next
            End If
        End With
        Set rngDiploma = Nothing
End Sub

 

[henryvanbeek]

het blijkt een appestrof te zijn in de naam van een collega te zijn.. Goed om te weten. Dit was de laatste naam in het rijtje dat ik even had aangemaakt dus ik nam aan dat hij klaar was.

Groetjes Henry