Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Filtern, Speichern, Zeilen löschen

Betrifft: Filtern, Speichern, Zeilen löschen von: Christoph
Geschrieben am: 08.09.2020 09:14:14

Hallo,
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) < 0 Then Exit Sub
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

Betrifft: AW: Filtern, Speichern, Zeilen löschen
von: fcs
Geschrieben am: 08.09.2020 23:17:59

Hallo Christoph,

ich habe das Makro angepasst.

Statt die zu erstellenden Blätter in der Mappe anzulegen werden diese jeweils in einer neuen Mappe angelegt und nach dem Ubertragen der Daten gespeichert und geschlossen.

LG
Franz
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 wkbZiel As Workbook
  Dim lngZeil As Long
  Dim varSuch As Variant
  Dim varSpalt As Variant
  Dim bolCut As Boolean
  Dim lngCZeil As Long
  Dim lngPZeil As Long
  Dim Pfad As String, sFileName As String
  
  varSpalt = InputBox("Bitte die Spalte eingeben, die durchsucht werden soll.", "Suchspalte", "" _
)
  If varSpalt = False Then Exit Sub
  varSpalt = Val(varSpalt)
  If varSpalt > 255 Or varSpalt < 1 Then Exit Sub
  
  Set wkbBasis = ActiveWorkbook
  Set wksBasis = ActiveSheet
  
  'Anfang des Dateinamens der erstellten Dateien
  sFileName = wkbBasis.Name
  sFileName = Left(sFileName, InStrRev(sFileName, ".") - 1) & "-"
  
  lngZeil = 2
  
  If wksBasis.Cells(lngZeil, varSpalt).Text = "" Then
    MsgBox "Keine Daten zum Kopieren vorhanden"
    Exit Sub
  End If
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Bitte Verzeichnis für die erstellten Blätter/Dateien auswählen/erstellen"
    .InitialFileName = ActiveWorkbook.Path
    If .Show = -1 Then
      Pfad = .SelectedItems(1) & Application.PathSeparator
    Else
      Exit Sub
    End If
  End With
  
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  
  Do
    varSuch = wksBasis.Cells(lngZeil, varSpalt)
    'neue Mappe mit 1 leeren Tabellenblatt erstellen
    Set wkbZiel = Application.Workbooks.Add(template:=xlWBATWorksheet) '
    Set wksZiel = wkbZiel.Worksheets(1)
    wksZiel.Name = varSuch
    'Titelzeile kopieren
    wksBasis.Cells(1, 1).EntireRow.Copy
    With wksZiel.Cells(1, 1)
      .PasteSpecial Paste:=xlPasteColumnWidths
      .PasteSpecial Paste:=xlPasteAll
    End With
    
    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
        lngPZeil = lngPZeil + 1
      End If
      If bolCut = False Then
        lngCZeil = lngCZeil + 1
      Else
        bolCut = False
      End If
    Loop Until IsEmpty(wksBasis.Cells(lngCZeil, varSpalt))
    
    Application.DisplayAlerts = False 'vorhandene Dateien werden ohne Rückfrage überschrieben
    wkbZiel.SaveAs Pfad & sFileName & varSuch & ".xlsx", 51 '51 = xlsx-Format, 56 = xls-Format
    wkbZiel.Close savechanges:=True
    Set wkbZiel = Nothing
    Application.DisplayAlerts = True
    
    lngZeil = lngZeil + 1
  Loop Until IsEmpty(wksBasis.Cells(lngZeil, varSpalt))
  
  Set wksZiel = Nothing
  Set wkbBasis = Nothing
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  MsgBox "Dateien wurden erfolgreich erstellt und gespeichert!"
End Sub


Betrifft: AW: Filtern, Speichern, Zeilen löschen
von: Christoph
Geschrieben am: 09.09.2020 08:04:50

Vielen Dank. Funktioniert perfekt!!!!

Betrifft: AW: Filtern, Speichern, Zeilen löschen
von: Christoph
Geschrieben am: 09.09.2020 11:36:27

Hallo Franz,
ein kleiner Fehler scheint noch zu bestehen. Wenn ich das Makro über die gewünschte Spalte laufen lasse, bleiben nach dem ersten durchführen ca. 10 Zeilen bestehen, nach der zweiten Durchführung 2 und mit dem letzten mal ist die Liste komplett abgearbeitet.
Nicht schlimm, da die Ausführung eines Makros nur ein Klick ist, aber etwas komisch.

Ansonsten Klasse, da ich mir nun eine Menge Zeit eingespart habe! Danke nochmals

Gruß
Christoph

Betrifft: AW: Filtern, Speichern, Zeilen löschen
von: fcs
Geschrieben am: 10.09.2020 02:23:49

Hallo Christoph,

der Grund können eigentlich nur leere Zellen in der Spalte sein.

Ich habe das Makro etwas umgeschrieben.
Die Zeilen im Basisblatt werden jetzt nicht mehr ausgeschnitten, sondern kopiert.

LG
Franz
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 wkbZiel As Workbook
  Dim lngZeil As Long
  Dim varSuch As Variant
  Dim varSpalt As Variant
  Dim arrCut() As Boolean
  Dim lngCZeil As Long, lngZeil_L As Long
  Dim lngPZeil As Long
  Dim Pfad As String, sFileName As String
  
  varSpalt = InputBox("Bitte die Spalte eingeben, die durchsucht werden soll.", "Suchspalte", "" _
)
  If varSpalt = False Then Exit Sub
  varSpalt = Val(varSpalt)
  If varSpalt > 255 Or varSpalt < 1 Then Exit Sub
  
  Set wkbBasis = ActiveWorkbook
  Set wksBasis = ActiveSheet
  
  'Anfang des Dateinamens der erstellten Dateien
  sFileName = wkbBasis.Name
  sFileName = Left(sFileName, InStrRev(sFileName, ".") - 1) & "-"
  
  
  If wksBasis.Cells(2, varSpalt).Text = "" Then
    MsgBox "Keine Daten zum Kopieren vorhanden"
    Exit Sub
  End If
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Bitte Verzeichnis für die erstellten Blätter/Dateien auswählen/erstellen"
    .InitialFileName = ActiveWorkbook.Path
    If .Show = -1 Then
      Pfad = .SelectedItems(1) & Application.PathSeparator
    Else
      Exit Sub
    End If
  End With
  
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With wksBasis
    lngZeil_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
    ReDim arrCut(1 To lngZeil_L)
  End With
  
  For lngZeil = 2 To lngZeil_L
    If arrCut(lngZeil) = False Then
      varSuch = wksBasis.Cells(lngZeil, varSpalt)
      'neue Mappe mit 1 leeren Tabellenblatt erstellen
      Set wkbZiel = Application.Workbooks.Add(template:=xlWBATWorksheet) '
      Set wksZiel = wkbZiel.Worksheets(1)
      wksZiel.Name = IIf(IsEmpty(varSuch), "(leer)", varSuch)
      'Titelzeile kopieren
      wksBasis.Cells(1, 1).EntireRow.Copy
      With wksZiel.Cells(1, 1)
        .PasteSpecial Paste:=xlPasteColumnWidths
        .PasteSpecial Paste:=xlPasteAll
      End With
      
      lngPZeil = 2
      For lngCZeil = lngZeil To lngZeil_L
      If arrCut(lngCZeil) = False Then
        If wksBasis.Cells(lngCZeil, varSpalt) = varSuch Then
          wksBasis.Cells(lngCZeil, 1).EntireRow.Copy Destination:=wksZiel.Cells(lngPZeil, 1)
          arrCut(lngCZeil) = True
          lngPZeil = lngPZeil + 1
        End If
      End If
      Next
      
      Application.DisplayAlerts = False 'vorhandene Dateien werden ohne Rückfrage überschrieben
      wkbZiel.SaveAs Pfad & sFileName & IIf(IsEmpty(varSuch), "(leer)", varSuch) _
          & ".xlsx", 51 '51 = xlsx-Format, 56 = xls-Format
      wkbZiel.Close savechanges:=True
      Set wkbZiel = Nothing
      Application.DisplayAlerts = True
    End If
  Next lngZeil
  
  Set wksZiel = Nothing
  Set wkbBasis = Nothing
  Erase arrCut
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  MsgBox "Dateien wurden erfolgreich erstellt und gespeichert!"
End Sub



Betrifft: AW: Filtern, Speichern, Zeilen löschen
von: Christoph
Geschrieben am: 10.09.2020 11:13:11

Perfekt! Vielen lieben Dank

Beiträge aus dem Excel-Forum zum Thema "Filtern, Speichern, Zeilen löschen"