VBA Bedingung aufstellen
23.06.2019 11:48:55
Pit
ich habe folgendes Anliegen:
Bei der Einteilung des Dienstes sollte ein definierter Prozentsatz aus dem Arbeitsblatt 3 - Zeile(D6) anstelle des absoluten "x" berücksichtigt werden, da sonst keine gleichmäßige und faire Anzahl an Diensten bei längerer Abwesenheit erfolgt.
Der %-Prozentsatz muss sich um jeden Tag (jede Schleife) um dem Wert 1 reduzieren.
Ich hatte bislang keinen großen Erfolg bei diesem Problem.
Für jeden Einsatz möchte ich mich bereits bedanken!
https://www.herber.de/bbs/user/130543.txt
Sub erstelleplan()
Call faerbeliste
Call uebertrageDienste
End Sub
Private Sub faerbeUrlaubsliste()
Dim zelleDatum, mitarbeiter As Variant, intRow As Long
Dim mRow, mAnz, anzahl As Long
Tabelle2.Range("A4:A10").Value = 0
For Each zelleDatum In Tabelle2.Range("C3:NO3")
anzahl = 2
If zelleDatum.Value "" And Weekday(zelleDatum) Then
For intRow = 1 To anzahl
mRow = 4: mAnz = 1000
For Each mitarbeiter In Tabelle2.Range("B4:B" & Tabelle2.Cells(Rows.Count, 2). _
_
End(xlUp).Row)
If Tabelle2.Cells(mitarbeiter.Row, zelleDatum.Column).Value "x" Then
If Tabelle2.Cells(mitarbeiter.Row, 1).Value 3 Then
mAnz = Tabelle2.Cells(mitarbeiter.Row, 1).Value
mRow = mitarbeiter.Row
End If
End If
Next mitarbeiter
Tabelle2.Cells(mRow, 1).Value = mAnz + 1
Tabelle2.Cells(mRow, zelleDatum.Column).Interior.ColorIndex = 3
Next intRow
End If
Next zelleDatum
End Sub
Private Sub uebertrageDienste()
Dim rng As Range, lastTab2 As Integer
Dim i As Integer, j As Integer, k As Integer, l As Integer: j = 2: l = 2
Set rng = Tabelle2.Range("C3:NO3")
lastTab2 = Tabelle2.Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To rng.Cells.Count Step 1
If Weekday(rng.Cells(i).Value) = rng.Cells(i).Value "" Then
Tabelle1.Cells(j, 1).Value = rng.Cells(i).Value
For k = 4 To lastTab2 Step 1
If Tabelle2.Cells(k, rng.Cells(i).Column).Interior.ColorIndex = 3 Then
Tabelle1.Cells(j, l).Value = Tabelle2.Cells(k, 2).Value
l = l + 1
Tabelle2.Cells(k, rng.Cells(i).Column).Value = "D"
End If
Next
l = 2
j = j + 1
End If
Next
End Sub