bakerman

Had 'm om te testen op vandaag gezet en vergeten terug te zetten. Private Sub Workbook_Open() With Sheets(1) For i = 2 To .Range("a1").End(xlDown).Row If (Day(CDate(.Range("c" & i).Value)) - Day(Date) = 1) * (Month(CDate(.Range("c" & i).Value)) - Month(Date) = 0) Then msg = msg & .Range("b" & i).Value & vbLf & vbLf End If Next i End With If msg <> vbNullString Then MsgBox msg & vbLf & "is (zijn) morgen jarig.", vbInformation, "Verjaardagen." End Sub

I.p.v. 3X op OK te moeten drukken. Private Sub Workbook_Open() With Sheets(1) For i = 2 To .Range("a1").End(xlDown).Row If (Day(CDate(.Range("c" & i).Value)) - Day(Date) = 0) * (Month(CDate(.Range("c" & i).Value)) - Month(Date) = 0) Then msg = msg & .Range("b" & i).Value & vbLf & vbLf End If Next i End With If msg <> vbNullString Then MsgBox msg & vbLf & "is (zijn) morgen jarig.", vbInformation, "Verjaardagen." End Sub

Deze heb ik je ook al eens eerder gegeven. Sub UpdateBestanden() Dim FilePath$, Row&, Column&, Address$ 'change constants & FilePath below to suit '*************************************** Const SheetName$ = "Personalia" Address = Cells(11, 2).Address FilePath = "D:\Test2\" '*************************************** With CreateObject("scripting.filesystemobject").getfolder(FilePath) For Each fl In .Files If Right(fl.Name, 5) = ".xlsx" Then Cells(Rows.Count, 1).End(xlUp).Offset(1) = fl.Name Filename = fl.Name Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = GetData(FilePath, Filename, SheetName, Address) Columns.AutoFit End If Next End With End Sub Private Function GetData(path, file, sheet, Address) Dim Data$ Data = "'" & path & "[" & file & "]" & sheet & "'!" & _ Range(Address).Range("A1").Address(, , xlR1C1) GetData = ExecuteExcel4Macro(Data) End Function

Een andere oplossing. Sub tst() Dim dic As Object, sn, i As Long sn = Blad2.Cells(1).CurrentRegion.Value Set dic = CreateObject("scripting.dictionary") For i = 2 To UBound(sn) If Not dic.exists(sn(i, 1)) Then dic.Add sn(i, 1), sn(i, 2) Else: dic.Item(sn(i, 1)) = dic.Item(sn(i, 1)) + sn(i, 2) End If Next sn = Blad1.Cells(1).CurrentRegion.Resize(, 3).Value For i = 2 To UBound(sn) If dic.exists(sn(i, 2)) Then sn(i, 3) = dic.Item(sn(i, 2)) Else: sn(i, 3) = 0 End If Next Blad1.Cells(1).Resize(UBound(sn), 3) = sn End Sub

Wijzig de Const wDir in de correcte map waar alle bestanden staan. Sub ConsolidateAll() Dim rsCon As Object, rsData As Object, sFileName As String Dim Prov As String, ExProp As String, resarr ', wDir As String Const wDir = "D:\Test2\" Prov = IIf(Val(Application.Version) < 12, "Microsoft.Jet.OLEDB.4.0", "Microsoft.ACE.OLEDB.12.0") ExProp = IIf(Val(Application.Version) < 12, "8.0", "12.0") Sheets(1).Cells(1).CurrentRegion.Offset(1).ClearContents sFileName = Dir(wDir & "*.xlsx") Do While sFileName <> "" If sFileName <> ThisWorkbook.Name Then Set rsCon = CreateObject("ADODB.Connection"): Set rsData = CreateObject("ADODB.Recordset") rsCon.Open "Provider=" & Prov & ";Data Source=" & wDir & sFileName & _ ";Extended Properties=""Excel " & ExProp & ";HDR=No"";" rsData.Open "SELECT * FROM [Personalia$B2:B14];", rsCon, 0, 1, 1 If Not rsData.EOF Then resarr = rsData.GetRows End If Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(resarr, 1) + 1, UBound(resarr, 2) + 1) = resarr sFileName = Dir: rsData.Close: Set rsData = Nothing: rsCon.Close: Set rsCon = Nothing End If Loop End Sub janlazeure.xlsm

Je databasebestand is leeg dus waar moeten de gegevens dan komen ?

Absoluut niet, dit was enkel een kort en bondige verduidelijking van de stappen die je moet ondernemen.

Selecteer de kolommen A tem L. In het lint ga je naar Pagina-indeling - Afdrukbereik. Selecteer Afdrukbereik bepalen en sla je bestand op.

Komaan man, ik post geen code die niet vooraf getest is. Ik post nu al 6 codes die bij mij perfect werken. Dus wat is er mis met jouw bestand ? Bekijk mijn schermafdruk maar eens (de uitgeprinte versie ziet er exact hetzelfde uit)

Sub afdrukken() Application.ScreenUpdating = False With Sheets(1) .PageSetup.Orientation = xlPortrait .Cells(1).CurrentRegion.Sort .Range("L1"), xlAscending, , , , , , xlYes .Range("A:A,C:K").EntireColumn.Hidden = True .PrintPreview 'PrintOut .Range("A:A,C:K").EntireColumn.Hidden = False .Cells(1).CurrentRegion.Sort .Range("B1"), xlAscending, , , , , , xlYes End With Application.ScreenUpdating = True End Sub

Test deze dan maar eens. K5.xlsm

Sub afdrukken() Application.ScreenUpdating = False With Sheets(1) .PageSetup.Orientation = xlPortrait .Cells(1).CurrentRegion.Sort .Range("K1"), xlAscending, , , , , , xlYes .Range("A:A,C:J").EntireColumn.Hidden = True .PrintPreview 'PrintOut .Range("A:A,C:J").EntireColumn.Hidden = False .Cells(1).CurrentRegion.Sort .Range("B1"), xlAscending, , , , , , xlYes End With Application.ScreenUpdating = True End Sub

Vermijd het gebruik van overbodige variabelen. Sub afdrukken2() Application.ScreenUpdating = False With Sheets(1) .PageSetup.Orientation = xlPortrait .Cells(1).CurrentRegion.Sort Key1:=.Range("I1"), Order1:=xlAscending, Header:=xlYes .Columns("B:H").EntireColumn.Hidden = True .PrintPreview 'PrintOut .Columns("B:H").EntireColumn.Hidden = False .Cells(1).CurrentRegion.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes End With Application.ScreenUpdating = True End Sub

Verbeterde code. Sub SelectiefPrinten() With Blad2 .Range("H2") = Application.InputBox("Geef het maandnummer op", , , , , , , 1) .Cells(1).CurrentRegion.Offset(1).ClearContents Blad1.Cells(1).CurrentRegion.AdvancedFilter 2, .Range("G1:H2"), .Range("A1:B1") With .Cells(1).CurrentRegion .Columns.AutoFit .PrintPreview End With End With End Sub

Wanneer je op de printknop drukt verschijnt een invulbox waarin je het maandnummer moet invullen. (zonder de voorloopnul) De code geeft je dan een printvoorbeeld. Je kan later de code wijzigen om rechtstreeks af te drukken. K5.xlsm

Dit is het beste dat ik voor je kan en wil doen. Voor al de rest worden de verschillen te groot om geprogrammeerd te krijgen. DhrFarduck.xlsb

Vervang dan de huidige code eens door deze. Sub tst() Dim col As New Collection Dim myarr With Sheets("Blad1") sn = .Cells(1, 2).CurrentRegion.Value End With With col For i = 2 To UBound(sn, 2) Step 2 For ii = 2 To UBound(sn) If sn(ii, i) <> vbNullString Then .Add Array(sn(ii, i + 1), sn(ii, i)), sn(ii, i + 1) Next Next ReDim myarr(1 To .Count, 1 To 2) End With x = 1 For Each i In col myarr(x, 1) = i(1): myarr(x, 2) = i(0) x = x + 1 Next With Sheets("Blad1").Cells(20, 1) .CurrentRegion.ClearContents .Resize(UBound(myarr), 2) = myarr End With End Sub

@alpha Het is een knop uit de collectie Formulierbesturingselementen die gebruikt is. @pd123 Draai jij toevallig De Mac-versie van Office ? Indien Ja dan zal Dictionary niet werken en moeten we overschakelen naar een Collection. Indien Neen dan moet je in de Opties voor Excel in het VertrouwensCentrum je instellingen nakijken dat je toegang verleent aan het Objectmodel.

Sub UpdateBestanden() Dim FilePath$, Row&, Column&, Address$ 'change constants & FilePath below to suit '*************************************** Const SheetName$ = "Blad1" Address = Cells(1).Address FilePath = "D:\Test2\" '*************************************** With CreateObject("scripting.filesystemobject").getfolder(FilePath) For Each fl In .Files If Right(fl.Name, 5) = ".xlsx" Then Cells(Rows.Count, 1).End(xlUp).Offset(1) = fl.Name Filename = fl.Name Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = GetData(FilePath, Filename, SheetName, Address) Columns.AutoFit End If Next End With End Sub Private Function GetData(path, file, sheet, Address) Dim Data$ Data = "'" & path & "[" & file & "]" & sheet & "'!" & _ Range(Address).Range("A1").Address(, , xlR1C1) GetData = ExecuteExcel4Macro(Data) End Function

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