Jede x-te Zeile löschen

Guten Morgen im neuen Jahr,
mit nachfolgendem Code lösche ich ab einer bestimmten Zeile jede x-te Zeile, wenn Spalte A belegt ist.
Sub Jede_X_te_Zeile_loeschen() Dim Zeile1, x Application.ScreenUpdating = False Zeile1 = Val(InputBox("Spalte A muss belegt sein !!" & vbCr & _ "Beginn in Zeile?", _ "Zeilen löschen")) x = Val(InputBox("Jede wievielte?")) Do While Not (IsEmpty(Cells(Zeile1, 1))) Rows(Zeile1).Delete Zeile1 = Zeile1 + x - 1 Loop Application.ScreenUpdating = True End Sub Ich möchte dies jetzt nicht mehr auf Spalte A prüfen ob belegt, sondern generell jede x-te Zeile ab der vorgegebenen Zeile aus der ersten Inputbox.
Wenn ich aber jetzt den Code ...While Not (IsEmpty(Cells(Zeile1, 1)))... entferne dauert das ewig, da vermutlich alle Zellen bis Zeile 1.048.576 durchsucht werden?!
Wie kann der Code geändert werden, damit ohne Bezug auf Spalte A nur bis zur maximal belegten Zelle (z. B.: Cells.SpecialCells(xlCellTypeLastCell).Row) der Code läuft?
Grüße - Erwin

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub JedeXteZeile() Dim Anfang As Long, Delta As Long Dim HS As Integer 'Hilfsspalte Dim letzeZeile As Long Anfang = 3 Delta = 4 HS = Cells(1, 2 ^ 14).End(xlToLeft).Column + 1 letzeZeile = Cells(2 ^ 20, 1).End(xlUp).Row Cells(1, HS) = 0 Range(Cells(2, HS), Cells(letzeZeile, HS)).Formula = _ "=IF(MOD(ROW()," & Delta & ")=" & Anfang & ",0,ROW())" ActiveSheet.UsedRange.RemoveDuplicates HS Columns(HS).Delete End Sub

Option Explicit Sub JedeXteZeile() Dim Anfang As Long, Delta As Long Dim HS As Integer 'Hilfsspalte Dim letzeZeile As Long Anfang = CInt(Application.InputBox("Startzeile", Type:=1)) Delta = CInt(Application.InputBox("ab welcher Zeile?", Type:=1)) HS = Cells(1, 2 ^ 14).End(xlToLeft).Column + 1 letzeZeile = Cells(2 ^ 20, 1).End(xlUp).Row Cells(1, HS) = 0 Range(Cells(2, HS), Cells(letzeZeile, HS)).Formula = _ "=IF(MOD(ROW()," & Delta & ")=" & Anfang & ",0,ROW())" ActiveSheet.UsedRange.RemoveDuplicates HS Columns(HS).Delete End Sub

Sub MalAnders() Dim Anfang As Long, Delta As Long, cnt As Long Dim letzeZeile As Long, Zeilen As Range Anfang = CInt(Application.InputBox("Startzeile", Type:=1)) Delta = CInt(Application.InputBox("jede wievielte Zeile?", Type:=1)) letzeZeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row Set Zeilen = Rows(Anfang + Delta) For cnt = Anfang + 2 * Delta To letzeZeile Step Delta Set Zeilen = Union(Zeilen, Rows(cnt)) Next If Not Zeilen Is Nothing Then Zeilen.EntireRow.Delete End Sub

Hi
RemoveDuplikats entfernt Zeilen mit Duplikaten.
der grosse Vorteil von RemoveDupliacates ist, dass es dabei sehr schnell ist und mit grössten Datenmengen funktioniert, egal wie die Zeilen liegen.
Alle anderen Löschmethoden sind nur dann schnell, wenn die zu löschenenden Zeilen einen lückenlos zusammenhängenden Block bilden, welcher in einem Vorgang gelöscht wird, dh die Zeilen müssen vor dem Löschen sortiert werden.
Removeduplicates ist aber auch in unsortierten Tabellen sehr schnell beim Löschen.
daher bietet es sich an, das RemoveDuplicats generell zum Löschen von Zeilen zu verwenden.
hierzu schreibt man in eine Hilfsspalte am Tabellenende eine Formel, welche alle Zeilen die gelöscht werden sollen mit dem selben Wert kennzeichnet (z.B. die 0) und alle Zeilen die stehen bleilben müssen, mit einem individuellen Wert, (z.B. der aktuellen Zeilennummer), damit man das RemoveDuplikates dann anwenden kann.
da das RemoveDuplicats immer eine Zeile mit dem "gleichwert" (0) stehen lässt, sollte man dafür sorgen, dass dieser "gleichwert" zusätzlich in einer Zeile steht, die stehen bleiben muss, Idalerweise nimmt man die Überschriftenzeile (welche sowieso jede Tabelle haben sollte)
ein weitere Vorteil dieser Methode ist, dass man sie auch von Hand problemlos anwenden kann, unabhängig von der Anzahl der Zeilen der Tabelle (dh man muss nicht immer ein Makro schreiben, wenn die Aufgabe "einmalig" ist)
wenn man es per Makro schreibt, dann lässt sich die Methode auch relativ einfach so programmieren, dass sie sich automatisch an die Tabellengrösse anpasst (Zeilen wie Spalten)
schau dir mal da Beispiel an:

Sub löschen_jede_X_Zeile()
Dim ErsteLöschZeile As Long
Dim Abstand As Long
Dim FO As String
FO = "=IF(Row()

Gruss Daniel

Sub LoescheXteZeile() a = Cells(Cells.Rows.Count, 1).End(xlUp).Row * 2 b = CInt(Application.InputBox("Startzeile?", Type:=1)) x = CInt(Application.InputBox("Jede wievielte Zeile?", Type:=1)) arr = Range("A1:A" & a) For i = b To a / 2 arr(i, 1) = arr(Int((i - 1) * x / (x - 1)) + 1, 1) Next Range("A1:A" & a) = arr End Sub

Sub LoescheXteZeile() a = Cells.CurrentRegion.Rows.Count * 2 b = CInt(Application.InputBox("Startzeile?", Type:=1)) x = CInt(Application.InputBox("Jede wievielte Zeile?", Type:=1)) arr = Range("A1:DZ" & a) For i = b To a / 2 For j = 1 To 100 arr(i, j) = arr(Int((i - 1) * x / (x - 1)) + 1, j) Next Next Range("A1:DZ" & a) = arr End Sub

Sub LoescheXteZeile() 'b=7 mit x=7 löscht Zeile 13, 20, 27 ... a = Cells.CurrentRegion.Rows.Count * 2 c = Cells.CurrentRegion.Columns.Count b = CInt(Application.InputBox("Startzeile?", Type:=1)) x = CInt(Application.InputBox("Jede wievielte Zeile?", Type:=1)) arr = Cells(1, 1).Resize(a, c) For i = b To a / 2 For j = 1 To c arr(i, j) = arr(Int((i - b) * x / (x - 1)) + b, j) Next Next Cells(1, 1).Resize(a, c) = arr End Sub

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

	A	B	C	D	E
1	Spalte A	0		ab Zeile:	3
2	x	2		jede xte	4
3	x	0
4	x	4
5	x	5
6	x	6
7	x	0
8	x	8
9	x	9
10	x	10
11	x	0
12	x	12
13	x	13
14	x	14
15	x	0
16	x	16

Jede x-te Zeile löschen

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread