Worksheets durchlaufen, Daten filtern
21.09.2021 11:36:26
Andreas
ich benötige wieder mal eure Profihilfe.
Ich habe unten stehenden Code für eine Auswertung (Rechnungen auslesen). Dieser läuft problemlos.
Ich möchte nun gerne eine weitere Auswertung (Zahlungen auslesen) erstellen.
Hierzu wird nur der loSuchbegriff benötigt, nachdem gesucht werden soll. Jedoch müssen alle Tabellenblätter durchlaufen werden, statt wie unten stehend
das Monatsblatt. Wie kann ich das bewerkstelligen? (Die Ergebniskopie passe ich danach noch an).
Option Explicit
Public Sub Daten_Rechnungen_holen()
Dim wbQuelle As Workbook, wsQuelle As Worksheet
Dim strPfad As String, strBlattname As String
Dim loLetzte As Long, loSuchbegriff As Long
Dim boVorhanden As Boolean
'### Deinen Pfad hier anpassen #####
strPfad = "\\NAS-2T\fibu\"
strBlattname = ActiveSheet.Name & " " & Right(Range("J3"), 2)
loSuchbegriff = ActiveSheet.Range("J1")
Application.ScreenUpdating = False
'Zielbereich leeren
With ActiveSheet
loLetzte = .Cells(.Rows.Count, 15).End(xlUp).Row
If loLetzte >= 4 Then
.Range(.Cells(4, 15), .Cells(loLetzte, 20)).ClearContents
End If
End With
'Datei Ausgangsrechnungen öffnen
Set wbQuelle = Workbooks.Open(strPfad & "Ausgangsrechnungen_rev2.7.xlsx")
With wbQuelle
'richtiges Quellblatt wählen
For Each wsQuelle In .Worksheets
If wsQuelle.Name = strBlattname Then
boVorhanden = True
'Quellblatt nach Kostenstelle filtern
With Worksheets(wsQuelle.Name)
loLetzte = .Cells(.Rows.Count, 5).End(xlUp).Row
.Range("$A$4:$T$" & loLetzte).AutoFilter Field:=5, Criteria1:=loSuchbegriff
loLetzte = .Cells(.Rows.Count, 5).End(xlUp).Row
If loLetzte """";P9;Q9)"
.Range(.Cells(9, 20), .Cells(loLetzte, 20)).Copy
.Range("M9").PasteSpecial Paste:=xlPasteValues
.Range(.Cells(9, 16), .Cells(loLetzte, 20)).ClearContents
End With
'Quellblatt ohne speichern schließen
wbQuelle.Close (False)
Application.CutCopyMode = False
End With
End If
End With
Exit For
End If
Next wsQuelle
End With
If Not boVorhanden Then
'MsgBox "Es ist kein Tabellenblatt " & """" & strBlattname & """" & " in Ausgangsrechnung vorhanden."
wbQuelle.Close (False)
End If
Dim cell As Range
For Each cell In Columns(11).SpecialCells(xlCellTypeConstants, 1 + 2)
With cell
If IsEmpty(cell) = False Then
.Offset(0, 3).NumberFormat = "DD.MM.YYYY" 'Format(Date, "General Date") Col N
.Offset(0, 3).HorizontalAlignment = xlCenter
.Offset(0, 4).Style = "Currency" 'Col O
.Offset(0, 2).HorizontalAlignment = xlLeft
With .Resize(, 5)
.Interior.Color = RGB(217, 217, 217)
.Font.Size = 12
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
End If
End With
Next cell
Range("K1:O1").EntireColumn.AutoFit
Set wbQuelle = Nothing
Application.ScreenUpdating = True
End Sub