Microsoft Excel

Herbers Excel/VBA-Archiv

Vergangene Daten rausfiltern

Betrifft: Vergangene Daten rausfiltern von: Elysa M
Geschrieben am: 19.10.2020 12:59:09

Guten Tag


Ich habe einen Code, der nach Monaten filtert. Auf einer Übersichtsseite erscheinen alle Zeilen, die ein Datum enthalten, welches in diesem oder in den nächsten zwei Monaten ist. Ursprünglich wurde kein Tag angegeben, deshalb enthält der Code keine Angabe des heutigen Tages, sondern nur "01."


Jedoch würde ich gern, dass auch jeweils der heutige Tag berücksichtigt wird, sodass alles, was bereits in der Vergangenheit ist, NICHT erscheint, auch wenn es im aktuellen Monat ist. Ich habe mehrere Sachen probiert, jedoch schaffe ich es nicht. Ich weiss, ich müsste noch den Tag als integer (z.B. k = Format(Date, "dd")) hinzufügen, jedoch weiss ich nicht, was ich mit dem machen soll.


Hier mein Code:



Public Sub CopyRows()

Dim ws As Worksheet
Dim s_Main As String
Dim nRow As Long
Dim Last_row As Long
Dim i As Long
Dim Table As Variant

Dim x as integer
Dim y as integer
Dim Date1 as string
Dim Date2 as string
Dim Date3 as string


s_Main = "Overview"
Last_row = Worksheets(s_Main).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(s_Main).Range("A2:P" & Last_row).ClearContents

x = Format(Date, "mm")
y = Format(Date, "yyyy")
Date1 = "01." & x & "." & y
If x = 12 Then
    x = 1
    y = y + 1
Else
    x = x + 1
End If
Date2 = "01." & x & "." & y
If x = 12 Then
    x = 1
    y = y + 1
Else
    x = x + 1
End If
Date3 = "01." & x & "." & y

For Each ws In Worksheets
    If ws.Name = s_Main Then
        GoTo Change_ws
    Else
        nRows = ws.Cells(Rows.Count, 1).End(xlUp).Row
        ReDim Table(nRows, 16)
        Table = ws.Range("A1:P" & nRows)
        For i = 1 To nRows
            If Table(i, 2) = Date1 Or Table(i, 2) = Date2 Or Table(i, 2) = Date3 Then
                Last_row = Worksheets(s_Main).Cells(Rows.Count, 1).End(xlUp).Row
                ws.Range("A" & i & ":P" & i).Copy Worksheets(s_Main).Range("A" & Last_row)(2)
            End If
        Next i
    End If
Change_ws:

Next ws
End Sub



Bin echt dankbar um jeden Hinweis! Vielen Dank!

Betrifft: AW: Vergangene Daten rausfiltern
von: fcs
Geschrieben am: 20.10.2020 05:39:17

Hallo Elysa,

wenn auf den Tabellenblättern das Datum in Spalte B kein Text ist, dann sollte folgende Anpassung funktionieren.

LG
Franz
Public Sub CopyRows()

    Dim ws As Worksheet
    Dim s_Main As String
    Dim nRows As Long
    Dim Last_row As Long
    Dim i As Long
    Dim Table As Variant
    
    Dim x As Integer
    Dim y As Integer
    Dim Date1 As Date
    Dim Date2 As Date
    Dim Date3 As Date
    
    
    s_Main = "Overview"
    Last_row = Worksheets(s_Main).Cells(Rows.Count, 1).End(xlUp).Row
    If Last_row > 1 Then Worksheets(s_Main).Range("A2:P" & Last_row).ClearContents
    
    Date1 = Date 'aktuelles Datum
 '   Date1 = DateSerial(2020, 12, 19) 'Test-Datum
    x = Month(Date1)
    y = Year(Date1)
    If x = 12 Then
        x = 1
        y = y + 1
    Else
        x = x + 1
    End If
    Date2 = DateSerial(y, x, 1) '1. des nächsten Monats
    If x = 12 Then
        x = 1
        y = y + 1
    Else
        x = x + 1
    End If
    Date3 = DateSerial(y, x + 1, 0) 'letzter Tag des übernächsten Monats
    
    For Each ws In Worksheets
        If ws.Name = s_Main Then
            GoTo Change_ws
        Else
            nRows = ws.Cells(Rows.Count, 1).End(xlUp).Row
            ReDim Table(nRows, 16)
            Table = ws.Range("A1:P" & nRows)
            For i = 1 To nRows
                If Table(i, 2) >= Date1 And Table(i, 2) <= Date3 Then
                    Last_row = Worksheets(s_Main).Cells(Rows.Count, 1).End(xlUp).Row
                    ws.Range("A" & i & ":P" & i).Copy Worksheets(s_Main).Range("A" & Last_row)( _
2)
                End If
            Next i
        End If
Change_ws:
    
    Next ws
End Sub


Beiträge aus dem Excel-Forum zum Thema "Vergangene Daten rausfiltern"