bakerman

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?

@ 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