Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1636to1640
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Begriffe fast zufällig verteilen

Begriffe fast zufällig verteilen
14.08.2018 21:17:06
Chris
Hallo,
ich möchte euch gerne um Eure Hilfe bitten.
Habe eine relativ simple Datei, 6 Begriffe in Tabelle1 Spalte C und die Daten von heute bis zum 13.8.19 in Tabelle2 Spalte A.
Mein Wunsch ist in Tabelle2 Spalte D jeden der 6 Begriffe gleich häufig in zufälliger Reihenfolge auszugeben (also 5 davon 61mal, einen davon 60mal, damit man auf 365 kommt).
https://www.herber.de/bbs/user/123336.xlsx
Jetzt aber das große Problem dass ich habe. An Freitagen und Samstagen sollen ausschließlich die Begriffe 5 oder 6 genommen werden.
Hat da jemand eine Idee?
Gruß und danke Christian

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
sorry doppelt
14.08.2018 21:17:23
Chris
.
AW: Begriffe fast zufällig verteilen
14.08.2018 22:01:49
Danyel
Hallo in Tabelle 2, in Zelle B1 diese Formel "=WOCHENTAG(A1;2)"
Tabelle 1 in SPALT A od. B von 1-7 durchnummerieren.
Dann in Tabelle 2 in der Spalte D einen SVerweis machen.
https://www.herber.de/bbs/user/123337.xls
AW: Begriffe fast zufällig verteilen
15.08.2018 21:32:09
Chris
Hallo Daniel,
nimms mir bitte nicht übel, aber das war leider nicht das was ich gesucht habe, ich wollte 6 vorgegebene Begriffe zufällig verteilen, die Datei die du mir schickst listet lediglich die 7 Wochentage auf.
Gruß
Christian
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


 ABCDEF
1Gruß Sepp
2
3

Anzeige
AW: Begriffe fast zufällig verteilen
15.08.2018 06:50:14
Chris
Hallo sepp,
Da scheint es ein misverständnis zu geben. Ich schrieb freitage nicht feiertage.
Viele grüße
Christian
AW: Begriffe fast zufällig verteilen
15.08.2018 07:02:48
Sepp
Hallo Christian,
tatsächlich habe ich Feiertag statt Freitag gelesen!
Dann so.
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
 
  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), vbSunday) > 5 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

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


 ABCDEF
1Gruß Sepp
2
3

Anzeige
AW: Begriffe fast zufällig verteilen
15.08.2018 21:39:17
Chris
Hallo Sepp,
sorry dass ich heut morgen so kurz angebunden war, hatte nur mal kurz während der Arbeit auf meinem Handy geschaut ob jemand geantwortet hat. Da ich auf dem Handy keine Excel Version hab die Makros verarbeiten kann gehe ich erst jetzt darauf ein, wo ich wieder daheim bin.
Danke auf jedenfall für deine Mühe. Mit einer kleinen Ausnahme ist es das was ich mir gewünscht hatte und ich denke für einen erfahrenen Makro Programmierer wie dich ist diese Ausnahme ein Kinderspiel abzuändern.
Ich hatte mir gewünscht dass die Ergebnisse in Tabelle2 Spalte D geschrieben werden, dein Makro schreibt sie in Spalte B.
Aber ansonsten hast du mir sehr weitergeholfen.
Vielen Dank
Christian
Anzeige
AW: Begriffe fast zufällig verteilen
15.08.2018 21:46:46
Sepp
Hallo Christian,
kein Problem und gleich eine verbesserte Version. Vorher wurde immer der letzte Begriff 60x verwendet, jetzt wird auch da per Zufall entschieden.
Sub zufall()
  Dim lngLast As Long, lngIndex As Long, lngRnd As Long, lngTmp() As Long, lngChoose() As Long
  Dim varDate As Variant, varOut() As Variant, varIn As Variant
 
  varIn = Sheets("Tabelle1").Range("C1:C6")
  
  Redim lngChoose(1 To Ubound(varIn, 1))
  
  Randomize Timer

  For lngIndex = 1 To Ubound(varIn, 1)
    Do
      lngRnd = Int(Ubound(varIn, 1) * Rnd) + 1
      If lngChoose(lngRnd) = 0 Then
        lngChoose(lngRnd) = lngIndex
        Exit Do
      End If
    Loop
  Next

  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) = lngChoose(lngIndex Mod Ubound(varIn, 1) + 1)
    Next
    
    For lngIndex = 1 To lngLast
      If Weekday(varDate(lngIndex, 1), vbSunday) > 5 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("D1").Resize(lngLast, 1) = varOut
  End With
End Sub

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


 ABCDEF
1Gruß Sepp
2
3

Anzeige
AW: Begriffe fast zufällig verteilen
17.08.2018 11:40:18
Chris
Hallo Sepp,
hab jetzt ausführlich geteset. Ist alles so wie es soll,
danke.
Christian

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige