bakerman

Of dit in Thisworkbook module zodat je enkel een melding krijgt van alle data bij het openen v/h bestand.

Private Sub Workbook_Open()
    With Blad1
        sn = .Range("C2", .Range("C" & .Rows.Count).End(xlUp))
    End With
    
    For i = 1 To UBound(sn)
        If sn(i, 1) <> vbNullString And sn(i, 1) < Date Then msg = msg & "Cel $C$" & i & vbLf
    Next
    
    If msg <> vbNullString Then MsgBox "Volgende data vervallen binnen het jaar." & vbLf & vbLf & msg
End Sub

Foto's in je bestand zetten zou ik ten sterkste afraden aangezien dit de grootte van je bestand nadelig gaat beïnvloeden.

Aangezien het om een fiche gaat zou ik er een ActiveX-ImageObject inzetten dat je kan laden met LoadPicture("volledig pad naar je foto")

Het automatisch laten wisselen van foto doe je dan met een Change-event macro die reageert op de verandering van huisnummer.

Maak er bij Namen een Dynamische Validatielijst van.

Op die manier kan je fruitsoorten toevoegen en verwijderen zonder dat je steeds je formule moet aanpassen.

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?