AW: Nächsten 20 Arbeitstage
31.05.2017 22:26:00
Piet
Hallo Christian
freut mich das dir mein Code gefaellt, Kleinigkeiten lassen sich immer aendern. Code einfach austauschen.
mfg Piet
Option Explicit '31.5.2017 Piet Herber Forum
'überarbeitet: C1-BRT wird aufgelistet
Const Tage = 20 'Anzahl Arbeitstage
Const lila = 19 'Innenfarbe "TA-1"
Const grün = 35 'Innenfarbe "C1-BRT"
Dim AC As Range, Fl As Worksheet
Dim AJ As Range, Rd As Worksheet
Dim z As Integer
Sub Arbeitstage_auflisten()
Dim Heute As Date, j As Integer
Dim lzFl As Long, lzRd As Long
Set Fl = Worksheets("Flächen")
Set Rd = Worksheets("Realdaten")
lzFl = Fl.Cells(Rows.Count, 1).End(xlUp).Row
lzRd = Rd.Cells(Rows.Count, 1).End(xlUp).Row
With Worksheets("Filter")
'alte Tabellen löschen
.Range("A4:J27").ClearContents
'erster Codeteil, zuerst in Sheet Realdaten
Heute = .Range("B1").Value
z = 4 '1. Zeile für TA-1 Termine
'Schleife für Realdaten auflisten
For j = 0 To Tage
'Datum in Realdaten suchen (Spalten "TA-")
For Each AC In Rd.Range("C2:O" & lzRd)
If AC.Value = Heute Then
If AC.Interior.ColorIndex = lila Then
.Cells(z, 1) = Rd.Cells(AC.Row, 1)
.Cells(z, 2) = Rd.Cells(1, AC.Column)
.Cells(z, 3) = AC.Value
z = z + 1
End If
End If
Next AC
'Heute auf naechsten Tag setzen
Heute = CDate(Heute + 1)
Next j
'zweiter Codeteil, diesmal in Sheet Flächen
Heute = .Range("B1").Value
z = 4 '1. Zeile für TA-1 Termine
'Schleife für Flächen auflisten
For j = 0 To Tage
'Datum in Flächen suchen (Spalten C)
For Each AC In Fl.Range("C3:C" & lzFl)
'Fehler im Beispiel verursachte Laufzeitfehler!!
If Trim(AC.Offset(0, -2)) = Empty Then Exit For
If AC.Value = Heute Then
.Cells(z, 6) = AC.Offset(0, -2) 'MSN
'** unklar ist mir Spalte G Wo kommt der Wert her ?
' .Cells(z, 7) ggf. selbst korrigieren !!
.Cells(z, 7) = AC.Offset(0, -1) 'Version ?
.Cells(z, 9) = AC.Offset(0, 1) 'CEC-1
.Cells(z, 10) = AC.Offset(0, 2) 'CEC-2
.Cells(z, 8) = AC.Value
z = z + 1
End If
Next AC
'Heute auf naechsten Tag setzen
Heute = CDate(Heute + 1)
Next j
'dritter Codeteil, diesmal in Sheet Realdaten
'Schleife für C1-BRT auflisten
For j = 4 To 27
Heute = .Cells(j, 8).Value
'Datum in Realdaten suchen (Spalten "TA-")
For Each AC In Rd.Range("C2:O" & lzRd)
If AC.Value = Heute Then
If AC.Interior.ColorIndex = grün Then
.Cells(j, 7) = Rd.Cells(1, AC.Column)
End If
End If
Next AC
Next j
End With
End Sub