Bereich ermitteln

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Bereich ermitteln

25.08.2016 09:57:08

Daniel

AW: Bereich ermitteln

25.08.2016 10:14:33

Fennek

AW: Bereich ermitteln

25.08.2016 10:25:26

Daniel

AW: Bereich ermitteln

25.08.2016 10:38:19

Daniel

halbe Frage?

25.08.2016 12:01:59

Michael

AW: halbe Frage?

25.08.2016 13:34:14

Daniel

AW: halbe Frage?

25.08.2016 13:34:17

Daniel

AW: halbe Frage?

25.08.2016 16:57:02

Michael

AW: halbe Frage?

26.08.2016 07:43:58

Daniel

AW: halbe Frage?

26.08.2016 14:55:04

Michael

AW: halbe Frage?

29.08.2016 07:38:00

Daniel

AW: halbe Frage?

29.08.2016 15:14:02

Daniel

ganze Antwort

29.08.2016 15:52:01

Michael

Sub test() Dim letztezeile As Integer Dim frei As Long letztezeile = Range("A1048576").End(xlUp).Row For i = 2 To letztezeile MsgBox (i) If Cells(i, 2) 0 Then frei = Range("B" & i & ":" & "B" & letztezeile).End(xlDown).Row i = frei End If Next i End Sub

Moin Michael,
danke das du dich dem Problem widmest.
Zu deiner Frage mit der Bereinigung.
Das bezieht sich immer auf die Startzeit.
Um das Beispiel von dir aufzugreifen sieht man dann in A10 die Hauptstörung die um 6:08 anfing und bis 6:09 ging. Aber diese Störung verursachte Folgestörungen, die immer maximal 1 Minute Differenz zueinander haben dürfen sprich man vergleicht B10 mit A11, B11 mit A12 und zu weiter. Dann stellt man fest das die letzte Folgestörung bis 6:27 ging. Also hat die Hauptstörung einen Stillstand von 6:08 bis 6:27 verursacht und genau das will ich Filtern.
Nach meinem erklärten Beispiel ist die rote Zeit, die Zeit wann die Hauptstörung & alle Folgestörungen beseitigt wurden und die Anlage wieder starten kann. Deswegen muss die Rote Zeit, nicht in die oberste grüne Spalte, sondern in die nächstmöglich oberste gelbe Spalte da diese die Anfangsstörung aufzeigt.
Ich hoffe es ist jetzt etwas verständlicher geworden.
Zu deinem letzten Punkt:
Erst mal hast du recht ich hab mich da nicht klar genug ausgedrückt.
Ich möchte gerne alle Störungen Haupt + Folgestörungen in die anderen Blätter kopiert haben.
Hier z.B. für die ZHA010 (Spalte E = Stationsbezeichnung) A2:F8 für die ZHA 20 A9:F9 für die ZHA30 A10:A25 usw.
Kopieren oder verschieben, ist mir egal :)
Wenn es keinen großen Aufwand macht gerne die Blätter bei Bedarf erstellen.
Das wär echt Klasse wenn du mir da etwas coden könntest. Das würde mir auch für andere Bereiche dann enorm weiterhelfen, in den ich den Code als Grundlage nehmen kann.
Vielen Dank im Vorraus :)
gruß
Daniel

Hi Daniel,
anbei Datei mit Makro.
Es legt neue Blätter an, sofern nicht vorhanden, leert aber vorhandene, anstatt weitere Werte unten anzuhängen: das läßt sich mit ein paar Zeilen ändern, aber wir hatten den Punkt noch nicht angesprochen.
Das Ersetzen der Zeit erfolgt während des Kopierens in einer Schleife (siehe 3.b), die Du im Prinzip extrahieren und auf den "großen" Bestand anwenden *könntest* - dann aber hier rausnehmen solltest: wozu zweimal das Gleiche rechnen?
Datei: https://www.herber.de/bbs/user/107855.xlsm
Makro:

Option Explicit
Sub Kopieren()
Const abZ = 2
Dim vSh As Worksheet, nSh As Worksheet ' "von"-Sheet und "nach" bzw. "neu"-Sheet
Dim bisZ&, z&, i&
Dim MA, W ' W wie Werte
Dim MAz&
Dim vorhSh As String
Dim gemerkt
Dim t0 As Single, t1 As Single
t0 = Timer
' 1. Ermitteln vorhandener Blätter
vorhSh = "!"
For i = 1 To Sheets.Count
vorhSh = vorhSh & Sheets(i).Name & "!"
Next
' "!" dürfen in Blattnamen nicht vorkommen...
' 2. Ermitteln aller Begriffe
bisZ = Range("E" & Rows.Count).End(xlUp).Row
MA = Range("E1:G" & bisZ + 1) ' bis 1 mehr, weil leer
MAz = 1
For z = 2 To bisZ + 1
If MA(z, 1)  MA(z - 1, 1) Then
MAz = MAz + 1
MA(MAz, 1) = MA(z, 1)
MA(MAz, 2) = z
MA(MAz - 1, 3) = z - 1
End If
Next
Application.ScreenUpdating = False
' Die nächste Zeile dienen nur der Veranschaulichung und können dann entfernt werden.
'MsgBox "Hier mal ansehen..."
Range("j25").Resize(MAz, 3) = MA
' 3. Diverses
Set vSh = ActiveSheet
gemerkt = ""
For z = 2 To MAz - 1
' Hier noch die Gretchenfrage: Werte im Zielblatt UNTEN anhängen
' ODER alles überschreiben?
' 3.a Erzeugen der Blätter
If InStr(vorhSh, "!" & MA(z, 1) & "!") = 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
Set nSh = Sheets(Sheets.Count)
nSh.Name = MA(z, 1)
vorhSh = vorhSh & MA(z, 1) & "!" ' neuer Name in den Prüfstring
Else
Set nSh = Sheets(MA(z, 1))
nSh.Cells.Clear ' LÖSCHT alles im vorh. Blatt
End If
vSh.Range("A1:F1").Copy nSh.Range("A1") ' Kopieren der Überschrift
' 3.b Einlesen des Bereichs und Bearbeitung
W = vSh.Range("A" & MA(z, 2) & ":F" & MA(z, 3)) ' enthält je die Zeilen für Gleiche
For i = UBound(W) To 1 Step -1
If W(i, 2) = "" Then
If gemerkt = "" Then gemerkt = W(i, 3)
Else
If gemerkt  "" Then W(i, 3) = gemerkt: gemerkt = ""
End If
Next
' 3.c Schreiben des Arrays
nSh.Range("A2").Resize(UBound(W), 6) = W
Next
vSh.Activate
t1 = Timer
MsgBox (t1 - t0) * 1000
End Sub

Schöne Grüße,
Michael

Sub Kopieren() Const abZ = 2 Dim vSh As Worksheet, nSh As Worksheet ' "von"-Sheet und "nach" bzw. "neu"-Sheet Dim bisZ&, z&, i& Dim MA, W ' W wie Werte Dim MAz& Dim vorhSh As String Dim gemerkt, a Dim t0 As Single, t1 As Single t0 = Timer ' 1. Ermitteln vorhandener Blätter vorhSh = "!" For i = 1 To Sheets.Count vorhSh = vorhSh & Sheets(i).Name & "!" Next ' "!" dürfen in Blattnamen nicht vorkommen... '2. Ermitteln aller Begriffe bisZ = Range("E" & Rows.Count).End(xlUp).Row MA = Range("E1:G" & bisZ + 1) ' bis 1 mehr, weil leer MAz = 1 For z = 2 To bisZ + 1 If MA(z, 1) MA(z - 1, 1) Then MAz = MAz + 1 MA(MAz, 1) = MA(z, 1) MA(MAz, 2) = z MA(MAz - 1, 3) = z - 1 End If Next Application.ScreenUpdating = False ' Die nächste Zeile dienen nur der Veranschaulichung und können dann entfernt werden. 'MsgBox "Hier mal ansehen..." Range("j25").Resize(MAz, 3) = MA ' 3. Diverses Set vSh = ActiveSheet gemerkt = "" For z = 2 To MAz - 1 ' Hier noch die Gretchenfrage: Werte im Zielblatt UNTEN anhängen ' ODER alles überschreiben? ' 3.a Erzeugen der Blätter If InStr(vorhSh, "!" & MA(z, 1) & "!") = 0 Then Sheets.Add After:=Sheets(Sheets.Count) Set nSh = Sheets(Sheets.Count) nSh.Name = MA(z, 1) vorhSh = vorhSh & MA(z, 1) & "!" ' neuer Name in den Prüfstring Else Set nSh = Sheets(MA(z, 1)) nSh.Cells.Clear ' LÖSCHT alles im vorh. Blatt End If vSh.Range("A1:G1").Copy nSh.Range("A1") ' Kopieren der Überschrift ' 3.b Einlesen des Bereichs und Bearbeitung W = vSh.Range("A" & MA(z, 2) & ":G" & MA(z, 3)) ' enthält je die Zeilen für Gleiche For i = UBound(W) To 1 Step -1 If W(i, 2) = "" Then If gemerkt = "" Then gemerkt = W(i, 3) Else a = W(i, 7) If gemerkt "" Then W(i, 7) = Format((gemerkt - W(i, 3)) * 86400 + a, "0,00") If gemerkt "" Then W(i, 3) = gemerkt: gemerkt = "" End If Next ' 3.c Schreiben des Arrays nSh.Range("A2").Resize(UBound(W), 7) = W Next vSh.Activate t1 = Timer MsgBox (t1 - t0) * 1000 End Sub

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread