AW: VBA Zeilen verschieben wenn Bedingungen erfüllt
09.07.2013 10:41:02
fcs
Hallo Jochen,
bei dem Aufbau der Daten muss die Anzahl Zeilen je Projekt etwas anders ermittelt werden.
Ansonsten passt mein Makro schon.
Gruß
Franz
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