AW: Begriffe fast zufällig verteilen
14.08.2018 22:17:15
Sepp
Hallo Christian,
probier mal.
Modul Modul1
Option Explicit
Sub zufall()
Dim lngLast As Long, lngIndex As Long, lngRnd As Long, lngTmp() As Long
Dim varDate As Variant, varOut() As Variant, varIn As Variant
Dim strF As String
varIn = Sheets("Tabelle1").Range("C1:C6")
With Sheets("Tabelle2")
lngLast = .Cells(.Rows.Count, 1).End(xlUp).Row
varDate = .Range("A1:A" & lngLast)
Redim lngTmp(lngLast - 1)
Redim varOut(1 To lngLast, 1 To 1)
For lngIndex = 0 To lngLast - 1
lngTmp(lngIndex) = lngIndex Mod Ubound(varIn, 1) + 1
Next
Randomize Timer
For lngIndex = 1 To lngLast
If Weekday(varDate(lngIndex, 1), vbMonday) = 6 Or Feiertage(CDate(varDate(lngIndex, 1))) <> "" Then
Do
lngRnd = Int(Ubound(lngTmp) * Rnd)
Loop While lngTmp(lngRnd) < 5
varOut(lngIndex, 1) = varIn(lngTmp(lngRnd), 1)
lngTmp(lngRnd) = lngTmp(Ubound(lngTmp))
If Ubound(lngTmp) > 0 Then Redim Preserve lngTmp(Ubound(lngTmp) - 1)
End If
Next
For lngIndex = 1 To lngLast
If varOut(lngIndex, 1) = "" Then
lngRnd = Int(Ubound(lngTmp) * Rnd)
varOut(lngIndex, 1) = varIn(lngTmp(lngRnd), 1)
lngTmp(lngRnd) = lngTmp(Ubound(lngTmp))
If Ubound(lngTmp) > 0 Then Redim Preserve lngTmp(Ubound(lngTmp) - 1)
End If
Next
.Range("B1").Resize(lngLast, 1) = varOut
End With
End Sub
Private Function Feiertage(Datum As Date) As String
Dim J As Integer
Dim O As Date
J = Year(Datum)
O = Ostern(J)
Select Case Datum
Case Is = DateSerial(J, 1, 1)
Feiertage = "Neujahr"
Case Is = DateSerial(J, 1, 6)
Feiertage = "Dreikönig"
Case Is = O
'##Von Ostern abgeleitete Fest- und Gedenktage
Feiertage = "Ostersonntag"
Case Is = DateAdd("D", 1, O)
Feiertage = "Ostermontag"
Case Is = DateSerial(J, 5, 1)
Feiertage = "Erster Mai"
Case Is = DateAdd("D", 39, O)
Feiertage = "Christi Himmelfahrt"
Case Is = DateAdd("D", 49, O)
Feiertage = "Pfingstsonntag"
Case Is = DateAdd("D", 50, O)
Feiertage = "Pfingstmontag"
Case Is = DateAdd("D", 60, O)
Feiertage = "Fronleichnam"
'##
Case Is = DateSerial(J, 8, 15)
Feiertage = "Maria Himmelfahrt"
Case Is = DateSerial(J, 10, 26)
Feiertage = "National Feiertag"
Case Is = DateSerial(J, 11, 1)
Feiertage = "Allerheiligen"
Case Is = DateSerial(J, 12, 8)
Feiertage = "Maria Empfängnis"
Case Is = DateSerial(J, 12, 24)
Feiertage = "Heilig Abend"
Case Is = DateSerial(J, 12, 25)
Feiertage = "Christtag"
Case Is = DateSerial(J, 12, 26)
Feiertage = "Stefanitag"
Case Is = DateSerial(J, 12, 31)
Feiertage = "Silvester"
'' '##Von Weihnachten abgeleitete Fest- und Gedenktage
'' Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 35
'' Feiertage = "Volkstrauertag"
'' Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 32
'' Feiertage = "Buss- u. Bettag"
'' Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 28
'' Feiertage = "Totensonntag/Ewigkeitssonntag"
'' Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 21
'' Feiertage = "1. Advent"
'' Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 14
'' Feiertage = "2. Advent"
'' Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 7
'' Feiertage = "3. Advent"
'' Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2)
'' Feiertage = "4. Advent"
'' '##
Case Else
Feiertage = ""
End Select
End Function
Private Function Ostern(Year As Integer)
Dim D As Integer
D = (((255 - 11 * (Year Mod 19)) - 21) Mod 30) + 21
Ostern = DateSerial(Year, 3, 1) + D + (D > 48) + 6 - _
((Year + Year \ 4 + D + (D > 48) + 1) Mod 7)
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0