bakerman

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

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.