Daten verschieben - Code anpassen
14.05.2020 19:09:26
Wolfgang
den nachfolgenden Code konnte ich hier im Forum unter Rechereche entdecken.Ich würde ihn auch gerne nutzen, bräuchte aber gar nicht mehrere Bedingungen, wie es im Code noch programmiert ist. Mir würde reichen, dass die Zeilen entsprechend verschoben werden in denen in Spalte D eine 6 enthalten ist. Ich wäre für eine Hilfestellung, den Code entsprechend anzupassen, sehr dankbar.
Herzliche Grüße - Wolfgang
Sub Copy_Projekte_Status6()
Dim wksQ As Worksheet, wksZ As Worksheet
Dim ZeileQ As Long, ZeileAnz As Long, ZeileZ As Long, Zeilen As Long
Const Zeile1 = 2 '1. Zeile mit einem Projektnamen - ggf. anpassen !!
Set wksQ = Worksheets("Tabelle1") 'Projektübersicht - Tabellename ggf. anpassen
Set wksZ = Worksheets("Tabelle2") 'Archivblatt - Tabellename ggf. anpassen
With wksZ
'nächste freie Zeile im Zielblatt
ZeileZ = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
End With
With wksQ
If Zeile1 > .Cells(.Rows.Count, 3).End(xlUp).Row Then
MsgBox "Keine Projekte in Projektübersicht eingetragen"
Else
Zeilen = .Cells(.Rows.Count, 2).End(xlUp).Row
ZeileQ = Zeile1 '
Do
'Anzahl Projektzeilen ermitteln
ZeileAnz = Application.WorksheetFunction.CountIf(.Range(.Cells(Zeile1, 2), _
Cells(Zeilen, 2)), .Cells(ZeileQ, 2).Value)
'Prüfen, ob in Spalte D alle Zeilen des Projekts den Wert 6 haben
If Application.WorksheetFunction.CountIf(.Range(.Cells(ZeileQ, 4), _
.Cells(ZeileQ + ZeileAnz - 1, 4)), 6) = ZeileAnz Then
With .Range(.Rows(ZeileQ), .Rows(ZeileQ + ZeileAnz - 1))
.Copy Destination:=wksZ.Cells(ZeileZ, 1)
.ClearContents
End With
ZeileZ = ZeileZ + ZeileAnz
End If
ZeileQ = ZeileQ + ZeileAnz
Loop Until IsEmpty(.Cells(ZeileQ, 4))
'Leerzeilen löschen
With .Range(.Cells(Zeile1, 4), .Cells(ZeileQ, 4))
If Application.WorksheetFunction.CountBlank(.Cells) = 1 Then
MsgBox "Keine abgeschlossenen Projekte vorhanden"
Else
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlShiftUp
MsgBox "Abgeschlossene Projekte ins Archivblatt verschoben"
End If
End With
End If
End With
End Sub