Nur 15 Minutenwerte behalten, alle anderen löschen

Hi,
ich brauch mal wieder Eure Hilfe. Ich habe versucht verschiedene Codes au der Recherche miteinander zu kombinieren, leider ist das nicht ganz so geworden, wie ich erhofft hatte. Mein Problem: Ich habe eine Exceldatei, die ich aus einer anderen Exceldatei heraus öffne. Das funktioniert. Nun möchte ich in der neu geöffneten Datei in Spalte B die erste Zeile finden, es handelt sich um eine Uhrzeit, deren Minute 15 oder 30 oder 45 oder 00 enthält. Dazu habe ich folgendes Makro:


Sub Finde()
Dim LetzteZeile As Long, Zeile As Long
LetzteZeile = Range("A65536").End(xlUp).Row
For Zeile = 9 To LetzteZeile
If Minute(Cells(Zeile, 1)) Mod 15 = 0 Then
Cells(Zeile, 1).Select
SendKeys "{Enter}"
Exit Sub
End If
Next Zeile
End Sub

Nun möchte ich, das die nächsten 14 Zellen nach der gefundenen Minutenzahl gelöscht werden. Danach soll eine Zeile übersprungen werden, da es sich dabei wieder um eine Zeile handelt, deren Minutenzahl die 15 oder 30 oder 45 oder 00 enthält. Dann sollen wieder 14 Zeilen gelöscht werden, eine Zeile übersprungen werden, 14 Zeile löschen usw. Hierzu habe ich folgendes Makro in der Recherche gefunden.


Sub Tage_löschen()
Dim Anzahl_Zeilen_löschen As Integer
If ActiveCell = "" Then Exit Sub
Anzahl_Zeilen_löschen = 14
Rows(ActiveCell.Row & ":" & ActiveCell.Row + Anzahl_Zeilen_löschen - 1).Delete Shift:=xlUp
SendKeys "{Enter}"
End Sub

Aber irgendwie funktioniert das ganze nicht so ganz, bzw. wenn ich es hingebogen habe, dass das Makro zum löschen der Tage nicht nur einmal sondern mehrfach ausgeführt werden soll ( durch Worksheet_SelectionChange) dauert es ewig, bis alles abgearbeitet ist, da es sich zum Teil um 45000 Zeilen handelt.
Wer hat eventuell einen anderen Lösungsvorschlag für mich. Das Endresultat sollte nach dem ausführen des Makros sein, dass nur noch die Zeilen vorhanden sind, deren Minutenzahl (Zelle ist in hh.mm.ss formatiert) 15, 30, 45 und 00 sind. Alle anderen Zeilen sollen gelöscht werden.
Ich hoffe, jemand hat verstanden was ich möchte und hat Zeit und Muße mich zu unterstützen. Danke jedenfalls schon mal im Voraus,
Oliver

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

ich bin im mom in der arbeit und hab ned die möglichkeit das script zu schreiben, aber du brauchst im prinzip nur folendes:
eine while schleife die nicht abbricht, solange ein minutenwert in der zelle steht.
dann eine erkennung in abhängigkeit einer variable, die die zeilennummer bestimmt, ob 0 od 15 od 30 od 45 drinnen steht, falls ja einfach die ganze zeile wo anders hinkopiert.
dann einfach die zeilennummer um 1 erhöhen usw.
das macht dann eh die while schleife, bis eine zelle leer ist, also das ende der datenreihe da ist und dann bricht sie eh ab.
einigers was du dazu brauchst, stand ja eh schon in dem script das du geschribenab hast.
oder kennst dich mit dem überhaupt nicht aus?
falls du bis am abned nichts hast, mach ich dir das script.

Sub Finden() Dim Zeile_Loggerdaten As Integer, Zeile_Auswertung As Integer Application.ScreenUpdating = False Blattname = ActiveSheet.Name Zeile_Loggerdaten = 9 Zeile_Auswertung = 2 Sheets.Add.Name = "Auswertung" Sheets(Blattname).Select Do While ActiveSheet.Cells(Zeile_Loggerdaten, 1) <> "" If Minute(Cells(Zeile_Loggerdaten, 1)) Mod 15 = 0 _ Or Minute(Cells(Zeile_Loggerdaten, 1)) = 0 Then Zeile_Auswertung = Zeile_Auswertung + 1 Rows(Zeile_Loggerdaten).Copy Worksheets("Auswertung").Cells(Zeile_Auswertung, 1) End If Zeile_Loggerdaten = Zeile_Loggerdaten + 1 Loop End Sub

Sub L1() Dim LetzteZeile As Long, Zeile As Long Application.ScreenUpdating = False LetzteZeile = Range("A65536").End(xlUp).Row For Zeile = LetzteZeile To 9 Step -1 If Minute(Cells(Zeile, 1)) Mod 15 <> 0 Then Cells(Zeile, 1).EntireRow.Delete End If Next Zeile Application.ScreenUpdating = True End Sub

Sub L2() Dim LetzteZeile As Long, Zeile As Long, zielzeile As Long Application.ScreenUpdating = False Sheets("Tabelle1").Range("1:8").Copy Sheets("Tabelle2").Paste Destination:=Range("1:8") LetzteZeile = Sheets("Tabelle1").Range("A65536").End(xlUp).Row zielzeile = 9 For Zeile = 9 To LetzteZeile If Minute(Sheets("Tabelle1").Cells(Zeile, 1)) Mod 15 = 0 Then Sheets("Tabelle1").Cells(Zeile, 1).EntireRow.Copy Sheets("Tabelle2").Paste Destination:=Range("A" & zielzeile) zielzeile = zielzeile + 1 End If Next Zeile Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Nur 15 Minutenwerte behalten, alle anderen löschen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread