Zellwert bedingt, Bereich kopieren

Guten Tag in die Runde,
ich arbeite an einer Arbeitsschritt-Übersicht mit verschiedenen Stati die aus einem Datenblatt gezogen werden.
Der Hintergrund dabei ist, dass Arbeitsschritte die vergessen wurden und der nächste auftretende Arbeitschritt in der Übersicht auftauchen soll.
Konkret sollen immer drei Stati miteinander verglichen werden, der ausgewählte Status und der Status aus der Zeile darüber und darunter.
Wenn der Zellwert des Status in der Zeile darüber im Status gleich ist, aber der Status in der Zelle darunter unterschiedlich ist, dann soll die untere Zelle kopiert und auf die Übersichtsseite eingefügt werden.
Bsp. 2.1 Approved, 2.2. Approved, 2.3 Done - Zeile 12 mit 2.3 soll kopiert und auf Übersicht eingefügt werden
Wenn der Zellwert im Status oben und unten gleich ist, aber in der mittleren Zeile nicht, dann soll die mittlere Zelle kopiert werden
Bsp. Approved, Done, Approved - dann soll Zeile mit Status Done kopiert auf der Übersicht eingefügt werden
Ich scheitere dabei den Vergleich der Stati sinvoll in VBA umzusetzen, damit die richtigen Zeilen kopiert werden. Vielleicht hat jemand eine gute Idee und könnte mir weiterhelfen. Anbei ist eine Testdatei.
https://www.herber.de/bbs/user/138218.xlsx
Vielen Dank im voraus und beste Grüße

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub aaa() Dim i As Long, loLetzte As Long, strMitte As String Dim strOben As String, strUnten As String Application.ScreenUpdating = False With Worksheets("Datenblatt") loLetzte = .Cells(.Rows.Count, "B").End(xlUp).Row For i = 4 To loLetzte - 1 Step 3 strMitte = .Cells(i, "B") strOben = .Cells(i, "B").Offset(-1) strUnten = .Cells(i, "B").Offset(1) If strMitte = strOben And strMitte strUnten Then .Cells(i, "A").Offset(1).Resize(1, 4).Copy With Worksheets("Übersicht") .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row) _ .PasteSpecial Paste:=xlPasteValues End With ElseIf strOben = strUnten And strMitte strOben Then .Cells(i, "A").Resize(, 4).Copy With Worksheets("Übersicht") .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row) _ .PasteSpecial Paste:=xlPasteValues End With End If Next i End With Application.CutCopyMode = False End Sub

Private Sub - call sub arbeiten? Anbei ist die Testdatei mit dem Code: _ https://www.herber.de/bbs/user/138247.xlsm Der Code: Option Explicit Public Sub aaa() Dim i As Long, loLetzte As Long, strMitte As String Dim strOben As String, strUnten As String Application.ScreenUpdating = False ' Übersicht soll erneuert werden Sheets("Übersicht").Select Rows("4:24").Select Selection.ClearContents Rows("28:47").Select Selection.ClearContents With Worksheets("Datenblatt") loLetzte = .Cells(.Rows.Count, "B").End(xlUp).Row For i = 4 To loLetzte - 1 Step 3 strMitte = .Cells(i, "B") strOben = .Cells(i, "B").Offset(-1) strUnten = .Cells(i, "B").Offset(1) ' Anstehend If strMitte = strOben And strOben strUnten Then .Cells(i, "A").Offset(1).Resize(1, 4).Copy With Worksheets("Übersicht") .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row) _ .PasteSpecial Paste:=xlPasteValues End With ' Verzögert ElseIf strOben = strUnten And strMitte strOben And strMitte strUnten Then .Cells(i, "A").Resize(, 28).Copy With Worksheets("Übersicht") .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row) _ .PasteSpecial Paste:=xlPasteValues End With End If Next i End With Application.CutCopyMode = False End Sub 'Sub Kopieren() ' Dim RaZelle As Range 'Dim LoZeile As Long 'For Each RaZelle In Range("B4:B40") ' If RaZelle = Done Then ' Range("B" & RaZelle.Row & ":F" & RaZelle.Row).Copy Range("CE" & LoZeile + 1) ' LoZeile = LoZeile + 1 ' RaZelle.ClearContents 'End If 'Next RaZelle 'End Sub

Hallo,
diese beiden Makros in ein allgemeines Modul:

Option Explicit
Public Sub Status()
Dim i As Long, loLetzte As Long, strMitte As String
Dim strOben As String, strUnten As String
Dim raAnstehend As Range, raVerzögert As Range
Application.ScreenUpdating = False
' Übersicht soll erneuert werden
Worksheets("Übersicht").Range("A4:I1000").ClearContents
With Worksheets("Datenblatt")
loLetzte = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 4 To loLetzte - 1 Step 3
strMitte = .Cells(i, "B")
strOben = .Cells(i, "B").Offset(-1)
strUnten = .Cells(i, "B").Offset(1)
' Verzögert
If strOben = strUnten And strMitte  strOben And strMitte  strUnten Then
If raVerzögert Is Nothing Then
Set raVerzögert = .Range("A" & i & ":D" & i)
Else
Set raVerzögert = Union(raVerzögert, .Range("A" & i & ":D" & i))
End If
' Anstehend
ElseIf strMitte = strOben And strOben  strUnten Then
If raAnstehend Is Nothing Then
Set raAnstehend = .Range("A" & i + 1 & ":D" & i + 1)
Else
Set raAnstehend = Union(raAnstehend, .Range("A" & i + 1 & ":D" & i + 1))
End If
End If
Next i
If Not raVerzögert Is Nothing Then
raVerzögert.Copy
Worksheets("Übersicht").Range("A4").PasteSpecial Paste:=xlPasteValues
End If
If Not raAnstehend Is Nothing Then
raAnstehend.Copy
Worksheets("Übersicht").Range("F4").PasteSpecial Paste:=xlPasteValues
End If
End With
Application.CutCopyMode = False
Set raVerzögert = Nothing: Set raAnstehend = Nothing
Call Kopieren_Done
End Sub
Sub Kopieren_Done()
Dim i As Long, raBereich As Range
Application.ScreenUpdating = False
Worksheets("Übersicht").Range("K4:N1000").ClearContents
With Worksheets("Datenblatt")
For i = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(i, "B") = "Done" Then
If raBereich Is Nothing Then
Set raBereich = (.Range("A" & i & ":D" & i))
Else
Set raBereich = Union(raBereich, .Range("A" & i & ":D" & i))
End If
End If
Next i
If Not raBereich Is Nothing Then
raBereich.Copy
Worksheets("Übersicht").Range("K4").PasteSpecial Paste:=xlPasteValues
End If
End With
Application.CutCopyMode = False
Set raBereich = Nothing
End Sub

Ins Codemodul von "DieseArbeitsmappe"

Private Sub Workbook_Open()
Call Status
End Sub

Im Zielblatt in Zelle A2: Verzögert
in Zellen A3 bis D3 die Überschriften ID / Status / Schritt / Beschreibung
Für Anstehend dann ab Spalte F und für Überprüfung ab Spalte K
Also die jeweiligen Datenbereiche immer mit einer Leerspalte dazwischen.
Im Moment kann ich nichts hochladen.
Gruß Werner

For i = 4 To loLetzte - 1 Step 3 strMitte = .Cells(i, "B") if strMitte "Approved" And strMitte "" then strOben = .Cells(i, "B").Offset(-1) strUnten = .Cells(i, "B").Offset(1) ' Verzögert If strOben = strUnten And strMitte strOben And strMitte strUnten Then If raVerzögert Is Nothing Then Set raVerzögert = .Range("A" & i & ":D" & i) Else Set raVerzögert = Union(raVerzögert, .Range("A" & i & ":D" & i)) End If ' Anstehend ElseIf strMitte = strOben And strOben strUnten Then If raAnstehend Is Nothing Then Set raAnstehend = .Range("A" & i + 1 & ":D" & i + 1) Else Set raAnstehend = Union(raAnstehend, .Range("A" & i + 1 & ":D" & i + 1)) End If End If End if Next i

For i = 4 To loLetzte - 1 Step 3 strMitte = .Cells(i, "B") strOben = .Cells(i, "B").Offset(-1) strUnten = .Cells(i, "B").Offset(1) ' Verzögert If strOben = strUnten And strMitte strOben And strMitte strUnten Then If .Range("B" & i) "Approved" And .Range("B" & i) "" Then If raVerzögert Is Nothing Then Set raVerzögert = .Range("A" & i & ":D" & i) Else Set raVerzögert = Union(raVerzögert, .Range("A" & i & ":D" & i)) End If End If ' Anstehend ElseIf strMitte = strOben And strOben strUnten Then If .Range("B" & i) "Approved" And .Range("B" & i) "" Then If raAnstehend Is Nothing Then Set raAnstehend = .Range("A" & i + 1 & ":D" & i + 1) Else Set raAnstehend = Union(raAnstehend, .Range("A" & i + 1 & ":D" & i + 1)) End If End If End If Next i

Beliebteste Forumthreads (12 Monate)

Zellwert bedingt, Bereich kopieren

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellwert bedingt, Bereich kopieren

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

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread