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. Mijn vraag was dus, hoe worden de maandnaam en de datum geschreven in je pad ?

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?