bakerman

=SUBSTITUEREN(RK[-2];".";"")-RK[-1] @ emiel Rechter Test.xlsm klikken.

Staan je weken horizontaal. Formule in A2 en naar rechts doortrekken. =VERSCHUIVING([Map2]Blad1!$B$42;0;(KOLOM()-1)*3) Staan je weken vertikaal. Formule in B1 en naar beneden dooretrekken. =VERSCHUIVING([Map2]Blad1!$B$42;0;(RIJ()-1)*3)

Een ideetje om makkelijk alle bladnamen in een kolom te krijgen. BladNamen_Formula.xlsm

Kleine aanpassing. Sub SortBirthdays() Application.ScreenUpdating = False Dim lRow As Long With Blad1 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row .Range("Z2:Z" & lRow).FormulaR1C1 = "=TEXT(RC3,""MMDD"")" .Range("A2:Z" & lRow).Sort .Range("Z2"), xlAscending, , , , , , xlNo .Range("Z2:Z" & lRow).Clear End With Application.ScreenUpdating = True End Sub en dan is dit het resultaat.

Deze sorteert op maand en dag. Je kan de dag en maandkolom zonder probleem verwijderen. Sub SortBirthdays() Application.ScreenUpdating = False Dim lRow As Long With Blad1 lRow = .Cells(.Rows.Count, 1).End(xlUp).Row .Range("Z2:Z" & lRow).FormulaR1C1 = "=TEXT(RC3,""MMDD"")" .Range("A2:Z" & lRow).Sort .Range("Z2"), xlAscending, , , , , , xlYes .Range("Z2:Z" & lRow).Clear End With Application.ScreenUpdating = True End Sub

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

Selecteer C2 en kies dan voor Voorwaardelijke Opmaak in het Lint. Kies Formule gebruiken om te kiezen welke cellen worden opgemaakt. Zet volgende formule in de witte balk. =$C$2 < $B$2 + 15 Kies dan je Opmaak en klik OK.

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