Zellwert bedingt, Bereich kopieren

Schlandro · 2020-06-11T11:32:39+00:00

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

Hallo Werner,
vielen Dank für die Hilfe. Der code funktioniert mit der Testdatei soweit. Ich wollte den Code jetzt etwas erweitern bin dabei jedoch auf neue Probleme gestoßen.
Zum einen wollte ich je nach Bedingung, dass der kopierte Text in eine andere Zeile in der Überischt eingefügt wird. Jedoch funktioniert es nicht wie gewünscht, den Fehler finde ich nicht.
Zum anderen wollte ich alle Zeilen kopieren in dem der Status Done vermerkt ist und auf der Übersicht einfügen. Mein 'Sub-kopieren' funktionert allerdings nicht.
Meine dritte Frage ist: Wenn das Makro atomatisch starten soll beim Öfnnen der Datei, muss ich _ dann mit dem Befehl


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

Besten Dank und ich hoffe ich habe mich verständlich ausgedrückt,
Beste Grüße

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

Zellwert bedingt, Bereich kopieren

Forumthread: Zellwert bedingt, Bereich kopieren

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Zellwert bedingt, Bereich kopieren

Forumthread: Zellwert bedingt, Bereich kopieren

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread