[VBA] Array + Matrix in gleiche Spalte eintragen ohne das andere zu überschreiben

[bergaa]

Moin zusammen,

folgendes Problem hat sich bei mir ergeben:

Ich habe eine Anzahl an Spieler und eine Anzahl an Freilosen. 
Je nach dem wie viel Freilose ich habe durch eine Variable i, möchte ich in meine Tabelle "Auslosung" nach einer Matrix Zellen beschreiben. (Mit dem Wort "Freilos")(Die Matrix befindet sich nicht im gleichen Tabellenblatt)
Danach möchte ich die Anzahl an Spielern die ich davor ermittelt habe und in ein Array eingelesen, per Zufall durchgemischt  in die gleiche Tabelle eintragen.
Dabei darf keine Zelle beschrieben oder befüllt werden in dem schon das Wort Freilos steht.

Es kann sich natürlich die Anzahl an Spielern und Freilosen je nach Anwendung des Plan's ändern. So muss ich alles variabel gestalten. 

In der Beispieldatei habe ich einige Info's hinterlassen.
Im Tabellenblatt "16er SKO" Info 1
Im Tabellenblatt "Freilose" Info 2
und nochmal ein Hinweis bzw. Beispiel auf dem Tabellenblatt "16er SKO".
Auch im meinem Codegestrüpp  habe ich einige Kommentare hinterlassen die evtl als Hinweis dienen oder helfen sollte.

Insgesamt sind in der Excel-Mappe 3 Tabellenblätter enthalten, dass Blatt das sich am Anfang öffnet ist vorausgefüllt.

Das wichtigste für euch, ja es gibt viele verbundene Zellen und sollte ich meine Mappe weiter entwickeln werde ich in Zukunft darauf verzichten. Hierbei aber durch einen komplexen Aufbau  und der Darstellung nicht mehr umzusetzen. Oder ehrlich gesagt ist mir das jetzt zu viel Arbeit.

Vielen Dank schon mal an jeden der mir da weiter helfen kann


  Beispieldatei.xlsm (Größe: 94,67 KB / Downloads: 2)

[Käpt'n Blaubär]

Hallo,

Das wichtigste für euch, ja es gibt viele verbundene Zellen und sollte ich meine Mappe weiter entwickeln werde ich in Zukunft darauf verzichten. 

... aus eigener, leidvoller Vergangenheit stammt die Erkenntnis:
nichts ist so beständig, wie ein Provisorium.

[snb]

Wo un wann wird die Lösung dieses Rätsels publiziert ?

Wenn die Aufhebung verbundene Zellen zuviel Arbeit ist, ist die Lösung deines Rätsel das für mich auch.

[Steffl]

Hallo,

Code:

Private Sub CommandButton1_Click()
Dim Antwort As VbMsgBoxResult
Dim Meldung As String
Dim i, z As Integer
Dim zaehler As Long
Dim varArray1 As Variant, varTemp As Variant
Dim intIndex As Integer, intRND As Integer

Meldung = "M?chten Sie wirklich Losen ?" & vbCrLf & vbCrLf & "Achten Sie darauf, dass Lose und Spieler" & vbCrLf & "zum Spielplan passen!"
Antwort = MsgBox(Meldung, vbYesNo + vbQuestion, "16er SKO Losung")

If Antwort = vbYes Then

   Range("K30:T45").ClearContents                                      'Inhalt der Zieltabelle l?schen

Else: Exit Sub
End If

   i = Range("AU31").Value                                             'Anzahl der Freilose
     
   zaehler = Range("AC30:AC45").Cells.Count - WorksheetFunction.CountBlank(Range("AC30:AC45"))
                           
   z = zaehler + i
'Wieso machst Du einen String daraus?
If z = 16 Then
'If z = "16" Then
   varArray1 = Range(Cells(30, 29), Cells(zaehler + 29, 29)).FormulaLocal    'Zelle AC30 bis AC(x) einlesen
   Randomize Timer                                                     'Zufallsgenerator initialisieren
Else
   MsgBox "Falsche Freilos Eingabe"
   GoTo Ende
End If

For intIndex = UBound(varArray1) To 1 Step -1                           'Array zuf?llig mischen
       intRND = Fix((intIndex * Rnd) + 1)
       varTemp = varArray1(intRND, 1)
       varArray1(intRND, 1) = varArray1(intIndex, 1)
       varArray1(intIndex, 1) = varTemp
Next

If i = 0 Then
   Range(Cells(30, 11), Cells(45, 11)).FormulaLocal = varArray1        'Ausgabe des Array ohne Freilos

   'Ab hier komme ich mit der Ausgabe ins straucheln
   'Falls das Feld Freilos leer bleibt oder 0 eingetragen wird trifft mein erster Fall ein
   'und falls i gr??er wie 8 sein sollte habe ich bereits auch eine L?sung, aber f?r i = 1-8 habe ich keinen Ansatz
   'Vielen Dank schonmal f?r Ihre M?he und f?r Ihre Zeit

ElseIf i > 8 Then MsgBox "Zu wenig Zu losende Spieler" & vbCrLf & "N?chst kleineren Plan verwenden"
Else
   Range(Cells(30, 11), Cells(29 + UBound(varArray1), 11)).FormulaLocal = varArray1

End If

Ende:

End Sub

[bergaa]

@ Steffl
Leider macht es nicht das was ich mir vorgestellt hatte und trotzdem ein danke an dich das du dich der Sache angenommen hast.

   

Da trage ich die Anzahl ein die ich verteilen möchte und diese Zahl wird in die Variable i gespeichert. 

Code:

i = Range("AU31").Value  

   

Aus dieser Matrix möchte ich die Zeilenposition herauslesen anhand der Größe von i. 
(Diese Matrix befindet sich auf einem anderen Tabellenblatt)

   

So sollte es aussehen wenn man an diesem Punkt der Verteilung der Freilose den Programmablauf anhalten könnte.
(Hier wie in der Beispieldatei i = 3, d.h. laut Matrix in Zeile 1, 16, 8 das Wort Freilos eintragen)
(3 Plätze von insgesamt 16 sind belegt, ergo fehlen noch 13 Spieler)

   

Diese 13 Spieler sind bereits in einem Array gespeichert und zufällig durchgemischt worden.

Code:

i = Range("AU31").Value     'Anzahl der Freilose
     
   zaehler = Range("AC30:AC45").Cells.Count - WorksheetFunction.CountBlank(Range("AC30:AC45"))
                           
   z = zaehler + i

If z = 16 Then
   varArray1 = Range(Cells(30, 29), Cells(zaehler + 29, 29)).FormulaLocal 'Zelle AC30 bis AC(x) einlesen
   Randomize Timer   'Zufallsgenerator initialisieren
Else
   MsgBox "Falsche Freilos Eingabe"
   GoTo Ende
End If

For intIndex = UBound(varArray1) To 1 Step -1  'Array zufällig mischen
       intRND = Fix((intIndex * Rnd) + 1)
       varTemp = varArray1(intRND, 1)
       varArray1(intRND, 1) = varArray1(intIndex, 1)
       varArray1(intIndex, 1) = varTemp
Next

 
Die Zuteilung der Freilose sollte nach dem Mischen des Arrays erfolgen  und dann möchte ich in den leeren Zeilen das Array ausgeben.
Ganz wichtig wäre, ich darf auf keinen Fall die Freilose die schon eingetragen wurden überschreiben.

   

So sollte dann das fertige Ergebnis aussehen.

(wichtig ist übrigens auch das in der Tabelle Auslosung keine Formel stehen darf, weil dieser Bereich wird mit einem anderen Button komplett gelöscht)

Danke nochmal, an alle die mir helfen möchten.  :28:
Ich hoffe so kommt ihr vielleicht einfacher auf eine Lösung. Ich wäre euch so dankbar.
(Beispieldatei im Startbeitrag)

[Steffl]

Hallo,

wenn nicht unbedingt im Bereich K30:K45 Formel stehen müssen geht es so.

Code:

Private Sub CommandButton1_Click()
Dim Antwort As VbMsgBoxResult
Dim Meldung As String
Dim i, z As Integer
Dim zaehler As Long
Dim varArray1 As Variant, varTemp As Variant
Dim intIndex As Integer, intRND As Integer
Dim lngA As Long
Dim rngZelle As Range

Meldung = "M?chten Sie wirklich Losen ?" & vbCrLf & vbCrLf & "Achten Sie darauf, dass Lose und Spieler" & vbCrLf & "zum Spielplan passen!"
Antwort = MsgBox(Meldung, vbYesNo + vbQuestion, "16er SKO Losung")

If Antwort = vbYes Then

   Range("K30:T45").ClearContents                                      'Inhalt der Zieltabelle l?schen

Else: Exit Sub
End If

   i = Range("AU31").Value                                             'Anzahl der Freilose
      
   zaehler = Range("AC30:AC45").Cells.Count - WorksheetFunction.CountBlank(Range("AC30:AC45"))
                          
   z = zaehler + i
'Wieso machst Du einen String daraus?
If z = 16 Then
'If z = "16" Then
   varArray1 = Range(Cells(30, 29), Cells(zaehler + 29, 29)).Value2    'Zelle AC30 bis AC(x) einlesen
   Randomize Timer                                                     'Zufallsgenerator initialisieren
Else
   MsgBox "Falsche Freilos Eingabe"
   GoTo Ende
End If

For intIndex = UBound(varArray1) To 1 Step -1                           'Array zuf?llig mischen
       intRND = Fix((intIndex * Rnd) + 1)
       varTemp = varArray1(intRND, 1)
       varArray1(intRND, 1) = varArray1(intIndex, 1)
       varArray1(intIndex, 1) = varTemp
Next

lngA = 1

Do
   Range("K30:K45").Cells(Worksheets("Freilose").Range("N8:Q9").Cells(lngA).Value).Value = "Freilos"
   lngA = lngA + 1
Loop While lngA <= i

If i = 0 Then
   Range(Cells(30, 11), Cells(45, 11)).FormulaLocal = varArray1        'Ausgabe des Array ohne Freilos

   'Ab hier komme ich mit der Ausgabe ins straucheln
   'Falls das Feld Freilos leer bleibt oder 0 eingetragen wird trifft mein erster Fall ein
   'und falls i gr??er wie 8 sein sollte habe ich bereits auch eine L?sung, aber f?r i = 1-8 habe ich keinen Ansatz
   'Vielen Dank schonmal f?r Ihre M?he und f?r Ihre Zeit

ElseIf i > 8 Then MsgBox "Zu wenig Zu losende Spieler" & vbCrLf & "N?chst kleineren Plan verwenden"
Else
   lngA = 1
   For Each rngZelle In Range("K30:K45")
       If rngZelle.Value = "" Then rngZelle.Value = varArray1(lngA, 1): lngA = lngA + 1
   Next rngZelle
  
'   Range(Cells(30, 11), Cells(29 + UBound(varArray1), 11)).FormulaLocal = varArray1

End If

Ende:

End Sub

[bergaa]

Guten Morgen @Steffl,

die Zulosung der Freilose funktioniert prima.

Aber danach kommt folgender Fehler:
   
   

Hab schon probiert selber eine Lösung zu finden aber irgendwie wird das nix. :22:

[Steffl]

Hallo,

kann ich nicht nachvollziehen. Gestern getestet, heute auch noch mal probiert, auch mit unterschiedlicher Anzahl von Freilosen. Es hat immer funktioniert.

[bergaa]

@Steffl

Lad mal bitte die Datei wo du das getestet hast hoch dann kann ich vergleichen.

Gruß Timo

[Steffl]

Hallo Timo,

ich habe das in deiner hochgeladenen Datei getestet. Vermutlich hast Du nur einen Teil vom Code eingefügt und dabei nicht bemerkt, dass ich oben beim Einlesen auch was geändert habe.