Zeilen schnell löschen

Sub B_loeschNot() Dim JCvariable As String JCvariable = Worksheets("Namen").Range("A6").Value 'hier müsste die Schleife für jeden Eintrag ab A6 bis A? starten Sheets("Daten").Select Call Speed_on 'Macro das aktualisierungen etc, ausschaltet '** Ermittlung der letzten Zeile in Spalte A lz = Cells(Rows.Count, 1).End(xlUp).Rows.Row '** Durchlauf aller Zeilen For t = lz To 2 Step -1 'Zählung rückwärts bis Zeile 2 'Abfragen, ob in der ersten Spalte der Buchstabe "x" steht If Cells(t, 4).Value JCvariable Then Rows(t).Delete Shift:=xlUp End If Next t Call Speed_off 'Jetzt müssten die Pivots refreshed werden 'Jetzt Die Datei unter dem Namen der Variablen JCvariable speichern 'Nächster eintrag in "Namen" ab A6 End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub AKillen() On Error GoTo Fehler Dim TB Dim SP%, ZE&, LR& Dim t Dim JCvariable As String JCvariable = Worksheets("Namen").Range("A6").Value t = Timer Set TB = Sheets("Daten") SP = 58 'Spalte BF ZE = 3 'Werte ab Zeile 3 With TB If .AutoFilterMode Then .AutoFilterMode = False ' Autofilter ausschalten LR = .Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte .Columns(SP).AutoFilter Field:=1, Criteria1:="" & JCvariable .Rows(ZE & ":" & LR).Delete Shift:=xlUp .AutoFilterMode = False End With 'MsgBox Round(Timer - t, 1) Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub ASichern() On Error GoTo Fehler Dim TB Dim SP%, ZE&, LR& Dim t Dim JCvariable As String JCvariable = Worksheets("Namen").Range("A6").Value t = Timer Set TB = Sheets("Daten") SP = 58 'Spalte BF ZE = 3 'Werte ab Zeile 3 With TB If .AutoFilterMode Then .AutoFilterMode = False ' Autofilter ausschalten LR = .Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte .Columns(SP).AutoFilter Field:=1, Criteria1:="" & JCvariable .Rows(ZE & ":" & LR).Delete Shift:=xlUp .AutoFilterMode = False End With 'MsgBox Round(Timer - t, 1) Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear Dim Neuer_Dateiname Dim DateiName As String DateiName = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 5) Neuer_Dateiname = DateiName & JCvariable & ".xlsb" If Neuer_Dateiname = False Then Exit Sub ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname Workbooks.Open DateiName & ".xlsb" End Sub

Sub DateienErstellen() Dim lr As Long, n As Long lr = Cells(Rows.Count).End(xlUp).Row For n = 6 To lr 'Schleife über Namen BearbeiteFall (Cells(n, 1)) Next End Sub Sub BearbeiteFall(MaName As String) Dim aw As Workbook Set aw = ActiveWorkbook Workbooks.Add aw.Sheets("NameDesSheetsDassZuKopierenIst").Copy '... ggf weitere sheets kopieren Worksheets("NameDesScheetsMitDerTabelleDieZuFilternIst").Select AKillen (MaName) 'Zeilen filtern ActiveWorkbook.SaveAs MaName + ".xlsx" ActiveWorkbook.Close False End Sub Sub akillen (JCvariable as string)

Hallo mmat,
vielen lieben Dank - eine Sache ist mir noch unklar - die einzelnen Namen bei Akillen:

Sub DateienErstellen()
Dim lr As Long, n As Long
Worksheets("Namen").Select   'den Blattnamen muß man ja mitteilen?
lr = Cells(Rows.Count).End(xlUp).Row
For n = 6 To lr 'Schleife über Namen
BearbeiteFall (Cells(n, 1))
Next
End Sub

Sub BearbeiteFall(MaName As String)
Dim DateiName As String 'Basisdatei in der alle Daten sind
Dim aw As Workbook
Set aw = ActiveWorkbook
Workbooks.Add
'Eigentlich muss ich keine Sheets kopieren?! Es ist ja eine Datei mit zig Tabellen und Pivots
' aw.Sheets("NameDesSheetsDassZuKopierenIst").Copy
'... ggf weitere sheets kopieren
' Worksheets("NameDesScheetsMitDerTabelleDieZuFilternIst").Select
akillen (MaName) 'Zeilen filtern
ActiveWorkbook.SaveAs MaName + ".xlsb"
ActiveWorkbook.Close False
Dim DateiName As String
Workbooks.Open DateiName & ".xlsb" ''Basisdatei in der alle Daten sind
End Sub

Sub akillen(JCvariable As String)
On Error GoTo Fehler
Dim TB
Dim SP%, ZE&, lr&
Dim t
Dim JCvariable As String
JCvariable = Worksheets("Namen").Range("A6").Value ' hier steht ja fest A6 das müsste ja  _
eine Schleife sein?
t = Timer
Set TB = Sheets("Daten")
SP = 58 'Spalte BF
ZE = 3 'Werte ab Zeile 3
With TB
If .AutoFilterMode Then .AutoFilterMode = False ' Autofilter ausschalten
lr = .Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
.Columns(SP).AutoFilter Field:=1, Criteria1:="" & JCvariable
.Rows(ZE & ":" & lr).Delete Shift:=xlUp
.AutoFilterMode = False
End With
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Wie bekomme ich die Schleife über die Namen in AKillen hin?
Vielen Dank und viele Grüße Lutz

Sub ASichern() On Error GoTo Fehler Dim TB Dim SP%, ZE&, lr& Dim t Dim JCvariable As String Dim lrs As Long Dim n As Long lrs = Worksheets("Namen").Cells(Rows.Count, 1).End(xlUp).Row For n = 6 To lrs 'Schleife über Namen JCvariable = Worksheets("Namen").Cells(n, 1).Value Set TB = Sheets("Daten") SP = 58 'Spalte BF ZE = 3 'Werte ab Zeile 3 With TB If .AutoFilterMode Then .AutoFilterMode = False ' Autofilter ausschalten lr = .Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte .Columns(SP).AutoFilter Field:=1, Criteria1:="" & JCvariable .Rows(ZE & ":" & lr).Delete Shift:=xlUp .AutoFilterMode = False End With Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear ActiveWorkbook.RefreshAll Dim Neuer_Dateiname Dim DateiName As String DateiName = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 5) Neuer_Dateiname = DateiName & JCvariable & ".xlsb" If Neuer_Dateiname = False Then Exit Sub ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname Workbooks.Open DateiName & ".xlsb" Next n End Sub

Hallo mmat,
vielen Dank noch einmal für Deine Hilfe.
Es läuft jetzt und zwar so:
ub ASichern()
On Error GoTo Fehler
Dim TB
Dim SP%, ZE&, lr&
Dim t
Dim JCvariable As String
Dim JCvariableKill As String
Dim lrs As Long
Dim n As Long
Dim Prefix As String
Prefix = Worksheets("VAR").Range("B7").Value & "_"
Worksheets("Name").Range("E4:F2028").ClearContents
Worksheets("Name").Range("A4:C2028").Copy
Worksheets("Name").Range("E4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
lrs = Worksheets("Name").Cells(Rows.Count, 5).End(xlUp).Row
For n = 4 To lrs 'Schleife über Namen
JCvariable = Worksheets("Name").Cells(n, 5).Value
JCvariableKill = Worksheets("Name").Cells(n, 7).Value
Set TB = Sheets("Daten")
SP = 58 'Spalte BF
ZE = 3 'Werte ab Zeile 3
With TB
If .AutoFilterMode Then .AutoFilterMode = False ' Autofilter ausschalten
lr = .Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
.Columns(SP).AutoFilter Field:=1, Criteria1:="" & JCvariable
.Rows(ZE & ":" & lr).Delete Shift:=xlUp
.AutoFilterMode = False
End With
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
ActiveWorkbook.RefreshAll
Dim Neuer_Dateiname
Dim DateiName As String
DateiName = Left(ActiveWorkbook.FullName, Len(ActiveWorkbook.FullName) - 5)
If n GROESSER 6 Then
Dim DateiNameKill As String
DateiNameKill = StrReverse(Split(StrReverse(DateiName), "\")(0)) & Prefix & JCvariableKill & ".xlsb"
Workbooks(DateiNameKill).Close savechanges:=False
End If
Neuer_Dateiname = DateiName & Prefix & JCvariable & ".xlsb"
If Neuer_Dateiname = False Then Exit Sub
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname
Workbooks.Open DateiName & ".xlsb"
Next n
End Sub
Ich muss immer den vorletzten schliessen aber erst ab dem 3ten Namen. Geht wunderbar, für 50 Namen unter 5 Minuten Laufzeit.
Es sieht so aus als wenn das Makro aus der Startdatei und aus der ersten Namensdatei läuft (wenn man die erste Namensdatei schliesst ist das Makro zu Ende).
Nochmals vielen Dank für Deine Hilfe.
Viele Grüße Lutz

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread