VBA importierte Liste nach Datum filtern
07.12.2022 10:40:09
Philipp
ich bin gerade dabei, ein Makro zu schreiben, dass importierte Daten automatisch filtert, teilweise löscht und dann Zusammenhänge erstellt.
Jetzt hakt es an der Stelle, wo nach dem Datum gefiltert werden soll. Alle Zeilen sollen gelöscht werden, bei denen das Datum in Spalte AJ später als der 7. Tag des darauffolgenden Monats liegt. Wenn ich das Makro laufen lasse, wird das passende Datum auch im Filter angezeigt (z.B. heute: "größer gleich 07.01.2023"), jedoch werden manche Zeilen gefiltert und andere nicht, scheinbar sehr willkürlich.
Die Spalte AJ ist als Datum formatiert.
Mein Gedanke war, alle Werte aus Spalte AJ in Zahlen umzuwandeln und danach zu filtern, aber irgendwie bekomme ich das nicht hin.
Hat vielleicht jemand eine Idee? Vielen Dank im Voraus! :-)
Viele Grüße
Philipp
Hier mein Makro (auszugsweise):
Sub Auswertung()
' Auswertung Makro
Dim strDatei As String
Dim Target As ListObject
Dim f As Office.FileDialog
Dim DatumBis As Date
Dim strPfadSuchen As String
Dim strDateiSuchen As String
Dim strDateiname As String
Dim strPfad As String
Dim strSheet As String
Dim strBR As String
Dim n As Integer
Dim x As Integer
'n = 1
x = 0
For n = 1 To 12
Start:
If n + x = 1 Then
strBR = "C46"
End If
If n + x = 2 Then
strBR = "C43"
End If
If n + x = 3 Then
strBR = "C41"
End If
If n + x = 4 Then
strBR = "C53"
End If
If n + x = 5 Then
strBR = "C48"
End If
If n + x = 6 Then
strBR = "C47"
End If
If n + x = 7 Then
strBR = "C94"
End If
If n + x = 8 Then
strBR = "C93"
End If
If n + x = 9 Then
strBR = "C40"
End If
If n + x = 10 Then
strBR = "C23"
End If
If n + x = 11 Then
strBR = "C26"
End If
If n + x = 12 Then
MsgBox ("Abgeschlossen mit Fehlern.")
GoTo EndProg
End If
strPfadSuchen = "C:\Testdateien\"
strDateiSuchen = Dir(strPfadSuchen & strBR & "*.csv", vbNormal)
ActiveWorkbook.Worksheets.Add After:=Sheets("Start")
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & strPfadSuchen & strDateiSuchen, Destination:=Range("$A$1"))
'On Error GoTo FehlerKeineDaten
.Name = " "
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
Rows("1:1").Select
Selection.AutoFilter
' Ab hier geht es los mit der Filterung nach Datum:
ActiveSheet.Range("$AJ$2:$AJ$99999").NumberFormat = "dd.mm.yyyy"
DatumBis = CDate("07." & ((Month(Now) + 1) Mod 12) & "." & Year(Now) + 1)
ActiveSheet.Range("$A:$AY").AutoFilter Field:=36, Criteria1:=">=" & DatumBis 'Wenn ich hier CDbl(DatumBis) eingebe, bekomme ich immerhin schon mal eine Zahl zum Filtern
Rows("2:999999").Select
Selection.Delete Shift:=xlUp '
Columns("$A:$AY").EntireColumn.AutoFit
ActiveSheet.Name = Range("$A$2")
strPfad = "C:\Positionen\" & Date & "\"
strSheet = Range("$A$2")
If Dir(strPfad, vbDirectory) = "" Then
MkDir (strPfad)
Else
End If
strDateiname = (Range("$A$2") & "_" & Date & ".xlsx")
Worksheets(strSheet).Copy
ActiveWorkbook.SaveAs strPfad & strDateiname
ActiveWorkbook.Close
End With
Next n
FehlerKeineDaten:
ActiveSheet.Name = strBR & " - Fehler!"
x = x + 1
On Error GoTo -1
GoTo Start
MsgBox ("Fertig! Gespeicherte Auswertungen siehe " & strPfad)
EndProg:
End Sub