Info maar 1 keer moeten invullen

[michielvd123]

Ik heb een korte macro opgesteld om een filter te kopieren naar een nieuw tabblad.
Ik werk met een inputbox om een filter met begin- en einddatum te kunnen instellen.
Ik maak ook een 2e filter op naam.

Nu wil ik deze macro kopieren voor andere namen en deze achter elkaar uitvoeren, maar ik wil uiteraard maar 1x de begin- en einddatum invullen. Hoe los ik dit op zodat hij dit maar 1x vraagt?

Hierbij wat ik heb:

Sub Yannick()

Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Yannick").Delete

Dim rng As Range
Set rng = Selection

Datum1 = Application.InputBox _
             (Prompt:="Gelieve begindatum op te geven.", _
                    Title:="Begindatum", Type:=1)
Datum2 = Application.InputBox _
             (Prompt:="Gelieve einddatum op te geven.", _
                    Title:="Einddatum", Type:=1)

rng.AutoFilter Field:=1, Criteria1:="Yannick"
rng.AutoFilter Field:=6, Criteria1:=">=" & Datum1, Operator:=xlAnd, Criteria2:="<=" & Datum2
Set rng = ActiveSheet.AutoFilter.Range
If rng.Columns(1).SpecialCells(xlVisible).Count - 1 = 0 Then
MsgBox "Geen info van Yannick!"
End If
  Set rngSelect = ActiveCell.CurrentRegion.SpecialCells(xlCellTypeVisible)
    rngSelect.Copy
Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
ActiveSheet.Name = "Yannick"
Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
Sheets("Blad1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveWorkbook.Save
End Sub

Bedankt!

 

[huijb]

Code dient tussen de codetags geplaatst te worden. Hiermee is het beter leesbaar voor de helpers. Zie ook hier http://www.helpmij.nl/forum/showthr...-de-helpers-in-deze-sectie-van-dienst-te-zijn

 

[mcs51mc]

Dit is misschien een oplossing

Option Explicit
Public Datum1      As Date
Public Datum2      As Date


Sub Yannick()
Dim rng         As Range
Dim rngSelect   As Range

    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Sheets("Yannick").Delete
    
    
    Set rng = Selection

    If Datum1 = 0 Then
        Datum1 = Application.InputBox _
                 (Prompt:="Gelieve begindatum op te geven.", _
                  Title:="Begindatum", _
                  Type:=1)
    End If
    
    If Datum2 = 0 Then
        Datum2 = Application.InputBox _
                 (Prompt:="Gelieve einddatum op te geven.", _
                  Title:="Einddatum", _
                  Type:=1)
    End If
    

rng.AutoFilter Field:=1, Criteria1:="Yannick"
rng.AutoFilter Field:=6, Criteria1:=">=" & Datum1, Operator:=xlAnd, Criteria2:="<=" & Datum2
Set rng = ActiveSheet.AutoFilter.Range
If rng.Columns(1).SpecialCells(xlVisible).Count - 1 = 0 Then
MsgBox "Geen info van Yannick!"
End If
  Set rngSelect = ActiveCell.CurrentRegion.SpecialCells(xlCellTypeVisible)
    rngSelect.Copy
Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Paste
ActiveSheet.Name = "Yannick"
Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
Sheets("Blad1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveWorkbook.Save
End Sub