bakerman

Probeer deze dan eens. pd123.xlsm

Weet niet hoeveel ervaring je hebt met VBA maar deze doet wat je vraagt. Sub tst() With Sheets("Blad1") sn = .Cells(1, 2).CurrentRegion.Value End With With CreateObject("scripting.dictionary") For i = 2 To UBound(sn, 2) Step 2 For ii = 2 To UBound(sn) If sn(ii, i) <> vbNullString Then .Add sn(ii, i + 1), sn(ii, i) x = x + 1 End If Next Next Sheets("Blad1").Cells(20, 1).Resize(x, 2) = Application.Transpose(Array(.items, .keys)) End With End Sub Heb je vragen laat maar iets weten.

Indien de bladnaam in elk bestand dezelfde is kan je het misschien makkelijker doen met een ExecuteExcel4Macro.

@dotchiejack Aangezien dit gaat over 100 files raad ik je aan om de ADODB stream en de ADODB recordset te gebruiken. Zelfs met deze 5 files was er al vertraging merkbaar.

CTRL + ; (kommapunt) geeft je de huidige datum CTRL + : (dubbelepunt) geeft je de huidige tijd

In de bladmodule van Blad1. Private Sub Worksheet_Change(ByVal Target As Range) If Target.Value = vbNullString Then Exit Sub If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("B6:B16")) Is Nothing Then Target.Offset(, 3) = Format(Date, "dd/mm/yyyy") Target.Offset(, 4) = Format(Time, "hh:mm") End If End Sub

Je wil het blijkbaar zo eenvoudig mogelijk. Probeer dan onderstaand bestand eens uit. Telkens je het Einduur invult op eender welk werkblad waarvan de naam begint met Persoon wordt de PT automatisch bijgewerkt. Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Name Like "Persoon*" Then If Not Intersect(Target, Sh.Columns(4)) Is Nothing Then With Sh .Unprotect "pcc2018" For Each pt In .PivotTables pt.PivotCache.Refresh Next .Protect "pcc2018" End With End If End If End Sub KarelG.xlsm

Vermijd het gebruik van Select, Selection, Activate. Het vertraagt de code en is in 99% van de gevallen overbodig. Maak gebruik van de With ..... End With structuur. Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("B:E")) Is Nothing Then With ActiveWorkbook.Sheets("Blad1") .Sort.SortFields.Clear .Sort.SortFields.Add Range("F2"), xlSortOnValues, xlDescending, , xlSortNormal With .Sort .SetRange Cells(1).CurrentRegion .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With End If End Sub

@ KarelG Enige reden waarom al je draaitabellen dezelfde gegevensbron hebben ?

Of zoals al eerder gezegd. Formule voor C2 en D2. =INDEX($L$1:$N$12;VERGELIJKEN($B2;$L$1:$L$12;0);KOLOM()-1)

Probeer het eens met deze. Sub test() sn = Blad2.Cells(3, 2).CurrentRegion.Value Set dic = CreateObject("scripting.dictionary") For i = 2 To UBound(sn) dic.Item(sn(i, 2)) = sn(i, 1) Next With Blad1 For Each cl In .Range("D3", .Range("D" & .Rows.Count).End(xlUp)) For Each Key In dic.keys If InStr(1, cl, Key, vbBinaryCompare) > 0 Then cl.Offset(, 1) = dic.Item(Key): Exit For Next Next End With End Sub Kenny1989_Dic.xlsm

Formules verder uitgewerkt. Jasper_II.xlsx

Als je op die manier wil zoeken zal je moeten overschakelen op een combinatie van Index en Vergelijken waarbij het wel mogelijk is om te verwijzen naar een vorige kolom. Dus zoeken in kolom C en resultaat van kolom A weergeven. Jasper.xlsx

Je format van kolom C staat op Tekst ipv Standaard. Fiets 3 is niet aanwezig in de A-kolom van je tabelmatrix op Sheet Producten.

Mogen of niet, hier is er eentje. De UDF in kolom B haalt het rekeningnummer uit de tekst. De Index/Match formule in kolom C zoekt dan een overeenkomst in de tabel. Kenny1989.xlsm

@emielDS Zonder foutafhandeling genereer je een foutmelding als Find geen overeenkomstig nummer kan vinden. Private Sub Annuleren_Click() 'aangeven zoekactie in worksheet Dim fRow With Sheets("Inschrijving") fRow = Application.Match(CLng(flightnummer), .Columns(1), 0) If Not IsError(fRow) Then .Cells(fRow, 1).Resize(, 8).ClearContents Else MsgBox "Geen nummer gevonden" End If End With End Sub

Ik heb een dynamische validatielijst in A4 gezet. Kijk maar eens bij Namen Beheren naar mylist. Onderhoudshandboek_pull down menu.xls

Gewoon een ander ideetje. Door in de TextBox letters in te typen wordt kolom A gefilterd. De Wis-knop verwijdert de tekst uit de TextBox en wist het Autofilter. Niko.xlsm

OK, ik heb het je makkelijk gemaakt. Onderstaande code zet alles om in hoofdletters en voegt een spatie toe als er een postcode tussen staat zonder spatie. Daarna wordt de samenvatting op Blad3 gezet. Sub Uniform_Samenvatten() sn = Blad1.Cells(1).CurrentRegion.Value Set dic = CreateObject("scripting.dictionary") With CreateObject("VBScript.RegExp") For i = 2 To UBound(sn, 2) For ii = 2 To UBound(sn) If sn(ii, i) <> vbNullString Then sn(ii, i) = UCase(sn(ii, i)) .Pattern = "\d{4}[A-Z]{2}" .Global = True If .test(sn(ii, i)) Then sn(ii, i) = Left(sn(ii, i), 4) & " " & Right(sn(ii, i), 2) If Not dic.exists(sn(ii, i)) Then dic.Add sn(ii, i), 1 Else dic.Item(sn(ii, i)) = dic.Item(sn(ii, i)) + 1 End If End If Next Next End With With Blad3 .Cells(1).CurrentRegion.ClearContents .Cells(1).Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items)) .Cells(1).CurrentRegion.Sort .Cells(1), xlAscending End With Blad1.Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn End Sub

Neen, dit is een invoer probleem van jouw zijde. Net zoals jij postcodes invoert met hoofd- en kleine letters door elkaar voer jij ook postcodes in met en zonder spatie. Voor jou lijken deze postcodes allemaal dezelfde maar voor Excel zijn deze eigenlijk allemaal uniek. 4536 AH is niet hetzelfde als 4536AH net zoals 4561rj niet hetzelfde is als 4561RJ. Waar jij dus voor moet zorgen is dat alle postcodes op dezeflde manier ingevoerd worden.

Resultaten komen op Blad3. Met hoofdletters en kleine letters heb ik rekening gehouden in de nieuwe code. Hou er echter rekening mee dat bv 4567 AH verschillend wordt gezien dan 467AH.

Met een beetje VBA is dit zo opgelost. Sub tst() sn = Blad1.Cells(1).CurrentRegion.Value With CreateObject("scripting.dictionary") For i = 1 To UBound(sn, 2) For ii = 1 To UBound(sn) If sn(ii, i) <> vbNullString Then If Not .exists(sn(ii, i)) Then .Add sn(ii, i), 1 Else .Item(sn(ii, i)) = .Item(sn(ii, i)) + 1 End If End If Next Next Blad1.Cells(1, 26).CurrentRegion.ClearContents Blad1.Cells(1, 26).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items)) Blad1.Cells(1, 26).CurrentRegion.Sort Blad1.Cells(1, 26), xlAscending End With End Sub

Er ontbreekt een backslash aan het eind van je TempFilePath.. En waarom gebruik je 2 externe subs om je Pdf te maken en te verzenden ?

Gebruik Application.InputBox dan kan je het type invoer bepalen. Vermijd het gebruik van onnodige variabelen, het maakt je code toch maar onleesbaar.

If sn(i, 1) <> vbNullString And sn(i, 1) < Date Then msg = msg & "Cel $C$" & i & vbLf moet zijn If sn(i, 1) <> vbNullString And sn(i, 1) < Date Then msg = msg & "Cel $C$" & i + 1 & vbLf