bakerman

Rechtsklik op de tab v/h betreffende werkblad en selecteer Programmacode weergeven.

Probeer maar eens op deze manier.

Private Sub PDF_rapport_maken()
    Dim pad As String
    Dim naam As String
    Dim foldername As String

    foldername = Sheets("voorblad").Range("a25").Value & "weekrapporten BOUWDIREKTIE"
    pad = foldername & "\"
    naam = "weekrapport BOUWDIREKTIE  " & Sheets("voorblad").Range("y8").Value & " WK-" & Sheets("voorblad").Range("y10").Value & Format$(Now, "  yyyy-mm-dd ")

    On Error Resume Next
    If Dir(foldername) = "" Then MkDir (foldername)
    
    myarr = Array("voorblad", "maandag", "dinsdag", "woensdag", "donderdag", "vrijdag", "zaterdag")
    For Each elm In myarr
        If elm = "voorblad" Then
            Sheets(elm).PageSetup.PrintArea = "$A$1:$AC$58"
        Else
            Sheets(elm).PageSetup.PrintArea = "$A$1:$AD$125"
        End If
    Next
    Sheets(Array("voorblad", "maandag", "dinsdag", "woensdag", "donderdag", "vrijdag", "zaterdag")).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pad & naam, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
    :=False, OpenAfterPublish:=True
    Worksheets("maandag").Select
End Sub

1. Select op zich activeert geen werkblad, het selecteert enkel een object. Goto doet dit wel.

2. Jij hebt daarom ook 3 functies nodig om je resultaat te halen (Activate - Find - Select)

3. Goto heeft een Scroll-funtie, Select niet.

4. Als jouw code de datum niet vind ga je in Debug terwijl mijn code de fout opvangt.

5. De variabele is inderdaad een variant omdat deze ook een fout moet kunnen accepteren. Als je deze zou instellen als een Integer zou je in geval van een fout in Debug gaan.

De Variant versie kan je beide aannemen en met de IsError-functie kan je de waarde bepalen en de juiste actie ondernemen.

Er gaat veel tijd verloren met over en weer kopieëren van gegevens, daarom bouw je best je array op in het geheugen en schrijf deze dan in 1X naar je werkblad Lijst.

Test deze maar eens met een variabel aantal rijen en kolommen.
 

Sub tst()
    Dim sn, sq, j As Long, i As Long, ii As Long
    't = Timer
    sn = Blad1.Cells(1).CurrentRegion.Value
    ReDim sq(1 To (UBound(sn) * UBound(sn, 2)), 1 To 3)
    j = 1
    
    For i = 2 To UBound(sn, 2)
        For ii = 2 To UBound(sn)
            sq(j, 1) = sn(1, i)
            sq(j, 2) = sn(ii, 1)
            sq(j, 3) = sn(ii, i)
            j = j + 1
        Next
    Next
    
    With Blad2
        .Cells(1).CurrentRegion.Offset(1).ClearContents
        .Cells(2, 1).Resize(UBound(sq), 3) = sq
    End With
    'MsgBox Timer - t
End Sub

Aangezien datums als getallen worden opgeslagen door XL is het aangewezen om dit ook toe te passen bij het zoeken naar een datum.

Vermijd ook het gebruik van Activate, Select, Selection ... in je code. In 99% van de gevallen werkt dit vertragend en is volstrekt overbodig.

Private Sub Workbook_Open()
    Dim x
    With Blad2
        x = Application.Match(CLng(Date), .Columns(2), 0)
        If Not IsError(x) Then Application.Goto .Cells(x, 1), True
    End With
End Sub

Als je enige ervaring hebt met VBA is dit kinderspel.

Sub tst()
    For i = 4 To 1000 Step 4
        Cells(i, 2).Value = "TEST"
    Next
End Sub

Hier kan je mee starten.

Sub RepHyperlinks()
    Dim hl As Hyperlink
    FindString = "oudetekst"
    ReplaceString = "nieuwetekst"
    For Each sh In Sheets
        For Each hl In sh.Hyperlinks
           If InStr(1, hl.Address, FindString) > 0 Then 'If FindString is found
                ReplaceLen = Len(FindString)
                URLLen = Len(hl.Address)
                PreStr = Mid(hl.Address, 1, InStr(1, hl.Address, FindString) - 1)
                PostStr = Mid(hl.Address, InStr(1, hl.Address, FindString) + ReplaceLen, URLLen)
                NewURL = PreStr & ReplaceString & PostStr
                hl.Address = NewURL 'Change the URL
            End If
        Next
    Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
With Target
    If .Count > 1 Then Exit Sub
    If Application.And(.Column = 2, .Value <> vbNullString) Then
        With .Offset(, -1)
            .NumberFormat = "dd/mm/yyyy hh:mm:ss"
            .Value = Now
        End With
    ElseIf Application.And(.Column = 2, .Value = vbNullString) Then
        .Offset(, -1).ClearContents
    End If
End With
End Sub

Wijzig het format van kolom A in dd/mm/jjjj uu:mm:ss

Volgende code volstaat dan.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target = vbNullString Then Exit Sub
    If Not Intersect(Target, Columns(2)) Is Nothing Then
        Target.Offset(, -1) = Now
    End If
End Sub

Net boven de ActiveWorkbook regel zet je

Application.DisplayAlerts = False

en er net onder

Application.DisplayAlerts = True

Waarom niet

If UCase(cl) = "X" Then

Heb jij Option Explicit bovenaan je module staan ?

Elke code die ik hier al gepost is getest door mij en werkend bevonden. Bij jou werkt er niks.

Ik vraag mij echt af waarom!!!!

Zo moeilijk is ie niet. Kiezen kijkt naar de waarde in C5. Is het 1 wordt de 1ste waarde van de reeks weergegeven, bij 2 de 2de, 3 de 3de, enz....

Elk nieuw object (volgend hoger nummer) voeg je dan achteraan toe in cel BE5.

Wel de formule dan wederom naar beneden doortrekken.

Beide tabbladen in 1 bestand, in 2 aparte bestanden ?

Opslaan als Pdf (geen wijzigingen meer mogelijk) of als XL-bestand (kunnen nog aanpassingen in aangebracht worden) ?

Volledig directorypad wordt handmatig aangemaakt, of moet via code gecontroleerd en aangemaakt worden ?

Dat kan met volgende formule in BE5 en dan met de vulgreep naar onder doortrekken.

=ALS(C5="";"";KIEZEN(C5;11,52;18,82;19,5;16,44))

Als je het op je USB-stick kan laten werken moet het op je harddrive ook werken.

Om uit te testen of het pad ook werkelijk bestaat kan je onderstaande eens gebruiken.

Wijzig het pad maar eens naar een bestaand en een onbestaand pad.

Sub test()
    MsgBox PathExists("g:\December\30-12-2016\")
End Sub
Private Function PathExists(pname) As Boolean
'   Returns TRUE if the path exists
    Dim x As String
    On Error Resume Next
    x = GetAttr(pname) And 0
    If Err = 0 Then PathExists = True _
      Else PathExists = False
End Function

Dit betekent dat er toch nog ergens een fout in het pad naar de juiste directory zit.

Als je de code nu gebruikt moet er een map December met een submap 29-12-2016 aanwezig zijn.

Heb je "Toegang tot het objectmodel van het VBA-project vertrouwen." aangevinkt ?

Meer kan ik niet voor je doen want hier werkt het perfect.

Ik heb je een voorbeeldbestandje gemaakt waar alles inzit dat je nodig hebt. (getest en goedgekeurd)

Zijn er vragen laat maar weten.

pscheppers.xlsm

Dit gaf je eerder op als volledig pad.

Quote

 

c:\Top\info\schouwing\schouwdiensten\afgewerkte diensten\maand\dag

 

Geef eens een voorbeeld van een volledige padnaam. De schrijfwijze is zeer belangrijk in dit geval.

Er moet dus telkens een kopie van het volledige bestand (alle 16 werkbladen) opgeslagen worden op de juiste dag in de juiste maand?

@ bucky

Voor zover ik weet is ExportAsFixedFormat enkel voor pdf of xps documenten (correct me if I'm wrong)

Vermijd Select, Activate, ActiveSheet in je code. In 99% van de gevallen is het overbodig en onnodig en zorgt het enkel voor vertraging en vervelende schermwisselingen.

Gebruik With...End With lussen in de plaats.

@ pscheppers

Plaats volgende code in een standaardmodule en link deze dan aan een knop.

Ik heb nu verkorte maandnamen gebruikt maar dit kan je aanpassen naar wens.

Sub tst()
    Application.CopyObjectsWithCells = False
    fname = "c:\Top\info\schouwing\schouwdiensten\afgewerkte diensten\" & _
        Choose(Month(Date), "Jan", "Feb", "Maa", "Apr", "Mei", "Jun", "Jul", "Aug", "Sept", "Okt", "Nov", "Dec") & "\" & _
        Format(Date, "dd-mm-yyyy") & "\" & "naam voor je formulier"
    Sheets("Naam van je formulierwerkblad").Copy
    With ActiveWorkbook
        .SaveAs fname, 51
        .Close True
    End With
    Application.CopyObjectsWithCells = True
End Sub

Test de bijlage maar eens uit.

Teams_Reinder.xlsm

Enkele woordjes uitleg.

1. Zorg er steeds voor dat je invulblad het 1ste werkblad in je bestand is.

2. Vul je invulblad volledig in alvorens de macro te starten.

3. Om typfouten in bladnamen of ontbrekende werkbladen te vermijden worden eerst alle werkbladen (buiten het invulblad) verwijderd.

4. Aan de hand van unieke locaties in kolom 4 worden de nieuwe werkbladen aangemaakt.

5. Alle ingevulde rijen worden automatisch verdeelt over de aangemaakte werkbladen.

Map111_ba.xlsm