Filtern, Speichern, Zeilen löschen
08.09.2020 09:14:14
Christoph
ich habe eine Tabelle, welche sich über PowerQuery aktualisiert und Berechnungen durchführt. Leider muss ich diese Tabelle nach bestimmten Kriterien aufteilen, in Dateien speichern, etc.
Ich habe ein Makro aus versch. Foren gebastelt und mit dem Rekorder gearbeitet. Mir gefällt es gut, dass die Kriterien über die Spalte abgefragt werden. Somit kann ich nach Kostenstelle, Abteilung oder Führungskraft die Daten aufbereiten.
Leider sind im jeweiligen Blatt die Leerzeilen noch enthalten und die neuen Blätter sollten nach dem speichern wieder gelöscht werden. Sahenhäupchen wäre natürlich noch eine kleine Tabelle mit dem Kriterium, habe ich aber immer mit der Funktion "Eindeutig" erledigt und meinen Verteiler dadurch erstellt.
Danke schon mal.
Gruß
Christoph
Sub Zeile_in_neues_Blatt()
'Prozedur, in der eine zu durchsuchende Spalte abgefragt wird
'Die unterschiedlichen Begriffe, die gefunden werden,
'werden je in ein neues Blatt kopiert.
'Startzeile ist 2
'Spalte muss vorher manuel sortiert werden
Dim wkbBasis As Workbook
Dim wksBasis As Worksheet
Dim wksZiel As Worksheet
Dim wks As Worksheet
Dim intBlatter As Integer
Dim lngZeil As Long
Dim intRow As Integer
Dim varSuch As Variant
Dim varSpalt As Variant
Dim bolCut As Boolean
Dim lngCZeil As Long
Dim lngPZeil As Long
varSpalt = InputBox("Bitte die Spalte eingeben, die durchsucht werden soll.", "Suchspalte", "")
If IsEmpty(varSpalt) Then Exit Sub
If Not IsNumeric(varSpalt) Then Exit Sub
If CInt(varSpalt) > 255 Or CInt(varSpalt) varSpalt = CByte(varSpalt)
Application.EnableEvents = False
Set wkbBasis = ActiveWorkbook
Set wksBasis = ActiveSheet
lngZeil = 2
Do
varSuch = wksBasis.Cells(lngZeil, varSpalt)
If wksBasis.Name = varSuch Then Exit Sub
wkbBasis.Sheets.Add after:=wksBasis
Set wksZiel = ActiveSheet
For Each wks In wkbBasis.Worksheets
If wks.Name = varSuch Then
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
Exit For
End If
Next
wksZiel.Name = varSuch
lngCZeil = 2
lngPZeil = 2
Do
If wksBasis.Cells(lngCZeil, varSpalt) = varSuch Then
wksBasis.Cells(lngCZeil, 1).EntireRow.Cut Destination:=wksZiel.Cells(lngPZeil, 1)
wksBasis.Cells(lngCZeil, 1).EntireRow.Delete
bolCut = True
End If
If bolCut = False Then
lngCZeil = lngCZeil + 1
bolCut = True
Else
lngPZeil = lngPZeil + 1
bolCut = False
End If
Loop Until IsEmpty(wksBasis.Cells(lngCZeil, varSpalt))
lngZeil = lngZeil + 1
Loop Until IsEmpty(wksBasis.Cells(lngZeil, varSpalt))
Set wksZiel = Nothing
Set wkbBasis = Nothing
Application.EnableEvents = True
End Sub Public bolAbfrage As Boolean
Sub Alles_Speichern()
Dim FileName As Variant
Dim Pfad As String
Dim FileExtension As String
If Not bolAbfrage Then
FileName = Application.GetSaveAsFilename(, "Excel Dateien (*.xlsx), *.xlsm") '*** welche Dateien auch immer
If FileName False Then
Pfad = GetFullPath(FileName)
FileExtension = GetFileExtension(FileName)
bolAbfrage = True
Else
Exit Sub
End If
End If
For i = 1 To ActiveWorkbook.Sheets.Count
Blatti = Sheets(i).Name
Sheets(i).Copy
ActiveWorkbook.SaveAs Pfad & ThisWorkbook.Name & "-" & Blatti & FileExtension '*** oder wie auch immer deine Datei heißen soll.
ActiveWorkbook.Close
Next i
MsgBox "Dateien wurden erfolgreich erstellt und gespeichert!"
bolAbfrage = False
End Sub
Public Function GetFileExtension(ByVal FullPath As String) As String
GetFileExtension = Right(FullPath, Len(FullPath) - InStrRev(FullPath, ".", -1) + 1)
End Function
Public Function GetFullPath(ByVal FullPath As String) As String
GetFullPath = Left(FullPath, InStrRev(FullPath, "\", -1))
End Function