Hallo Edgar,
danke für die Rückmeldung und Erklärung.
Ich bekomme das Coding von snb so schnell nicht zum laufen, da muss man wieder erst alles umbauen und deklarieren.
Probiere ich dann später noch einmal.
Der umgebaute Code von mir sollte aber bei Dir unbedingt funktionieren, denn dieser läuft bei mir in der von Dir oben geposteten Datei ohne Probleme durch. Und nochmal und nochmal und nochmal ...
Der entspricht genau Deinem Coding, nur etwas 'thematisch' getrennt.
Wenn das also ein wirkliches Projekt ist, dann würde ich eher objektorientiert vorgehen und eine Klasse dafür erstellen.
(Array geht zwar auch, ist aber aus meiner Sicht später nicht mehr so schön lesbar/änderbar/erweiterbar.)
Dann zuerst die Eigenschaften aller Buttons ermitteln/festlegen und in der Collection wegschreiben.
Zum Schluss in einem Rutsch die Button löschen und neu erstellen.
Der Vorteil wäre, dass alles lesbar ist der Code bis zum löschen und neu erstellen debugbar bleibt.
Gruß Carsten
Hi Carsten,
ich habe es auf einem anderen Rechner laufen lassen, funktioniert.
Was in Einzelfällen passiert ist, dass statt 9 auf einmal 10 blaue Felder erstellt werden, warum konnte ich noch nicht nachvollziehen.
Fehler gefunden:
Code:
Select Case InStr(myValues, Format(i, "00"))
Zitat:Wenn das also ein wirkliches Projekt ist, dann würde ich eher objektorientiert vorgehen und eine Klasse dafür erstellen.
Das übersteigt meine eher Anfängerkenntnisse.
Da konnte noch etwas verbessert werden:
Code:
Private Sub worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
If Target.Address <> "$M$2" Then Exit Sub
cancel = True
With Tabelle1
If .Shapes.Count = 0 Then
For j = 0 To 59
With .OLEObjects.Add("Forms.CommandButton.1")
.Name = "C_" & Format(jj, "00")
.Height = 60
.Width = 68.25
.Top = 30 + .Height * (j \ 6)
.Left = 259 + (j Mod 6) * (.Width + 0.75)
Tabelle1.Cells(1) = .Object.BackColor
End With
Next
End If
sn = Tabelle2.Cells(1).CurrentRegion
y = Abs(Int(6 * Rnd() - 0.01)) + 1
For j = 1 To UBound(sn)
If sn(j, y) = "" Then Exit For
Next
For jj = 0 To 59
With .OLEObjects("C_" & Format(jj, "00")).Object
.Caption = sn(Abs(Int((j - 2) * Rnd() - 0.01)) + 2, y)
.BackColor = RGB(200, 200, 200)
.ForeColor = RGB(0, 0, 0)
End With
Next
.[K1:K60] = "=rand()"
sp = [index(rank(T_OLE!K1:K60,T_OLE!K1:K60)-1,)]
.[K1:K60].ClearContents
For j = 1 To 14
With .OLEObjects("C_" & Format(sp(j, 1), "00")).Object
.BackColor = IIf(sp(j, 1) < 27, RGB(0, 0, 255), IIf(sp(j, 1) < 38, RGB(200, 100, 0), RGB(100, 100, 100)))
If sp(j, 1) < 27 Then .ForeColor = RGB(255, 255, 255)
End With
Next
End With
End Sub
... und auch manchmal elf.
Eben nochmal geschaut:
Dies wird ja auch nirgendwo begrenzt. Es werden derzeit 14 Zufallszahlen zwischen 1 und 61 erzeugt.
Rein theoretisch könnte es im Moment auch 14 blaue geben, wenn alle 14 Zufallszahlen kleiner 27 sind.
Wenn man Deine Bedingungen kennen würde, dann könnte man die Erzeugung der Zufallszahlen auch etwas besser angehen.
Zum Beispiel könnte man prüfen, dass es nur maximal 9 Zahlen kleiner als 27 geben darf. Oder was auch immer
Ansonsten ist mir ein Fehler bei meinen Änderungen aufgefallen:
Bitte ersetze in der Sub CreateMyButton die Zeile Case 28 To 38 durch Case 27 To 37.
Dies entspricht Deinem ersten Coding, ändert aber am eben angesprochenem Problem nichts.
Gruß Carsten
(08.02.2018, 08:56)BoskoBiati schrieb: [ -> ]Fehler gefunden:
Code:
Select Case InStr(myValues, Format(i, "00"))
Ja, stimmt. Da habe ich verschlimmbessert.
Richtig wäre:
Frage:
Gibt es eine weitere Regel für die Anzahl der farbigen Button?
@snb:
Habe deine Datei angeschaut, interessantes Coding wie immer. ;)
Aber leider immer mit Laufzeitfehler
1004-Element nicht gefunden und falscher Aufbau.
Gruß Carsten
Hi,
die Beschränkung ist da. Mit Instr wird ja nur die Stelle gesucht, an der die Zahl im Array steht. Es wird als der CB mit der aktuellen Nummer gefärbt, wenn diese im Array vorkommt. Problem war, dass Zahlen kleiner 10 durchaus in größeren Zahlen weiter vorne gefunden wurden. Die Änderung des Vergleichs hat das gelöst.
Das mit Case 27 hattee ich schon geändert.
Mit Split könnte man evtl. das Array aufdröseln und die CB´s direkt ansprechen. In meinem Originalcode war das das Array arrZahlen2().
Regeln für die Farben: 9 blaue u. 4 braune Felder sowie 1 graues Feld
Nochmal nachgeschaut:
Mit dem arrZahlen2() hast Du aber nichts gemacht. Es wurde gefüllt und war dann nur noch 'sinnlos' vorhanden. Es wurde nie abgefragt, deshalb habe ich es entfernt.
Ok, könntest Du mal bitte Deinen aktuellen Code posten, damit wir auf der gleichen Basis sind?
Zu Deiner Bemerkung mit Deinen Kenntnissen:
Wenn Du möchtest, dass ich Dir eine kleine Vorgabe erstelle, dann solltest Du diese problemlos verstehen und erweitern können.
Vermute ich mal so ...
Einschränkung vorweg, obwohl interessant:
Ich habe aber heute nicht mehr sehr viel Zeit, erst am späten Abend wieder.
Gruß Carsten
Es geht primär um die Programmierungvorstöße; nich um Exakte 'Lösung'.
- analyse von Programmierstufen
- 'richtige' bau der Code
- Vermeidung verbundener Zellen
- Minimierung der Arbeitsblattinteraktion (keine ExcelFormeln wo VBA reicht)
Man sollte fähig sein die Code nur ein wenig an zu passen an den exakte Bedingungen/Wünsche (wie lernt man anders ??).
Es scheint mir etwas aufwändig/doof immer die Oleobjects neu zu gestalten wenn die immer in identischen Stellen stehen sollten.
DoppelKlicke mal verschiedene Male in M2
Noch etwas näher zur 'Lösung':
Code:
Private Sub worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
If Target.Address <> "$M$2" Then Exit Sub
cancel = True
With Tabelle1
If .Shapes.Count = 0 Then
sn = Array(0, 5, 11, 18, 26, 35, 43, 50, 56, 61, 70)
For j = 0 To 60
y = Application.Match(j, sn, 1) - 1
With .OLEObjects.Add("Forms.CommandButton.1")
.Name = "C_" & Format(j, "00")
.Height = 60
.Width = 68.25
.Top = 30 + .Height * y
.Left = 259 - IIf(y < 5, y, 8 - y) * (.Width + 0.75) / 2 + (j - sn(y)) * (.Width + 0.75)
End With
Next
End If
sn = Tabelle2.Cells(1).CurrentRegion
y = Abs(Int(6 * Rnd() - 0.01)) + 1
For j = 1 To UBound(sn)
If sn(j, y) = "" Then Exit For
Next
For jj = 0 To 60
With .OLEObjects("C_" & Format(jj, "00")).Object
.Caption = sn(Abs(Int((j - 2) * Rnd() - 0.01)) + 2, y)
.BackColor = RGB(200, 200, 200)
.ForeColor = RGB(0, 0, 0)
End With
Next
.[K1:K61] = "=rand()"
sp = [index(rank(T_OLE!K1:K61,T_OLE!K1:K61)-1,)]
.[K1:K61].ClearContents
For j = 1 To 14
With .OLEObjects("C_" & Format(sp(j, 1), "00")).Object
.BackColor = IIf(sp(j, 1) < 27, RGB(0, 0, 255), IIf(sp(j, 1) < 38, RGB(200, 100, 0), RGB(100, 100, 100)))
If sp(j, 1) < 27 Then .ForeColor = RGB(255, 255, 255)
End With
Next
End With
End Sub
Hi Carsten,
Du hast recht. Das stammte aus einem vorhergehenden Code, bei dem ich anders vorgegangen bin.
Aktuell sieht mein Code so aus:
Code:
Sub test()
Dim loA As Long
Dim loB As Long
Dim lozahl As Long
Dim loZahl2 As Long
Dim loC As Long
Dim CB(61)
Dim strB As String
Dim strName As String
Dim arrZahlen, arrZahlen2(13)
With Sheets("Tabelle2")
On Error Resume Next
Application.ScreenUpdating = False
.Shapes.SelectAll
Selection.Delete
On Error GoTo Fehler
Do
Randomize
loC = Application.WorksheetFunction.RandBetween(1, 61)
If InStr(arrZahlen, loC) = 0 Then
arrZahlen = Format(loC, "00") & "," & arrZahlen 'Zufallszahlen in ein mit Leerzeichen getrennt in ein Array schreiben
arrZahlen2(loB) = loC
loB = loB + 1
End If
Loop While loB < 14
.Cells(1, 2).FormulaLocal = "=INDEX(Liste!1:1;ZUFALLSBEREICH(0;5)*2+1)"
.Cells(1, 2).Value = .Cells(1, 2).Value
For loA = 1 To 61
.Cells(1, 1).FormulaLocal = "=SVERWEIS(ZUFALLSBEREICH(1;200);INDEX(Liste!$1:$1;VERGLEICH($B$1;Liste!$1:$1;0)):INDEX(Liste!$26:$26;VERGLEICH($b$1;Liste!$1:$1;0)+1);2;1)"
strName = .Cells(1, 1)
Set CB(loA) = .OLEObjects.Add("Forms.CommandButton.1") 'Button einfügen
CB(loA).Object.Caption = strName
CB(loA).Height = 60
CB(loA).Width = 68.25
strB = Format(loA, "00")
If InStr(arrZahlen, strB) <> 0 Then
'----------------------
If InStr(arrZahlen, Format(loA, "00")) < 26 Then
CB(loA).Object.BackColor = RGB(0, 0, 255)
CB(loA).Object.ForeColor = RGB(255, 255, 255)
ElseIf InStr(arrZahlen, Format(loA, "00")) < 38 And InStr(arrZahlen, loA) > 27 Then
CB(loA).Object.BackColor = RGB(200, 100, 0)
Else
CB(loA).Object.BackColor = RGB(100, 100, 100)
End If
End If
' -------------------------------
If loA < 6 Then
CB(loA).Top = 30
CB(loA).Left = 259 + (loA - 1) * 69
ElseIf loA < 12 Then
CB(loA).Top = 90
CB(loA).Left = 259 + (loA - 6) * 69 - 34
ElseIf loA < 19 Then
CB(loA).Top = 150
CB(loA).Left = 259 + (loA - 13) * 69
ElseIf loA < 27 Then
CB(loA).Top = 210
CB(loA).Left = 259 + (loA - 20) * 69
ElseIf loA < 36 Then
CB(loA).Top = 270
CB(loA).Left = 259 + (loA - 29) * 69
ElseIf loA < 44 Then
CB(loA).Top = 330
CB(loA).Left = 259 + (loA - 37) * 69 - 34
ElseIf loA < 51 Then
CB(loA).Top = 390
CB(loA).Left = 259 + (loA - 45) * 69
ElseIf loA < 57 Then
CB(loA).Top = 450
CB(loA).Left = 259 + (loA - 51) * 68.25 - 34
Else
CB(loA).Top = 510
CB(loA).Left = 259 + (loA - 57) * 68.25
End If
Next
.Range("a1").Clear
.Range("B2") = "Doppelklick hier!"
End With
Application.ScreenUpdating = True
Exit Sub
Fehler: MsgBox (Err.Number & " " & Err.Description & "--> Button " & loA & " " & strName & " " & arrZahlen)
End Sub
Und bei Deinen habe ich die beiden bearbeitet:
Code:
Private Function CreateMyValues() As String
On Error GoTo Er
Dim i As Integer
Dim loC As Long
Dim myValues As String
Do
Randomize
loC = Application.WorksheetFunction.RandBetween(1, 61)
If InStr(myValues, loC) = 0 Then
myValues = Format(loC, "00") & "," & myValues
i = i + 1
End If
Loop While i < 14
CreateMyValues = myValues
Ex:
Exit Function
Er:
MsgBox Err.Number & vbNewLine & Err.Description, vbCritical, "Sub CreateMyValues"
Resume Ex
End Function
Private Sub CreateMyButton(ByVal sh As Worksheet, ByVal strCaption As String, ByVal myValues As String, ByVal i As Integer)
On Error GoTo Er
Dim o As Object
Set o = sh.OLEObjects.Add(ClassType:="Forms.Commandbutton.1", Width:=68.25, Height:=60)
If o Is Nothing Then Exit Sub
With o
.Object.Caption = strCaption
If InStr(myValues, Format(i, "00")) <> 0 Then
Select Case InStr(myValues, Format(i, "00"))
Case Is < 27
.Object.BackColor = RGB(0, 0, 255)
.Object.ForeColor = RGB(255, 255, 255)
Case 27 To 38
.Object.BackColor = RGB(200, 100, 0)
Case Else
.Object.BackColor = RGB(100, 100, 100)
End Select
End If
End With
ArrangeMyObject o, i
Ex:
Set o = Nothing
Exit Sub
Er:
MsgBox Err.Number & vbNewLine & Err.Description, vbCritical, "Sub CreateMyButton"
Resume Ex
End Sub
Was meine Kenntnisse betrifft, mit Klassen kann ich nichts anfangen, ansonsten verstehe ich Deine Codes und auch die von snb, ich bin auch in der Lage diese abzuwandeln.
Theoretisch habe ich heute auch kaum Zeit noch was zu machen.
@snb:
Ja, mit dem aktuellen Hintergrundwissen von Edgars Problem: Man muss diese nicht immer neu erstellen.
Im Gegenteil, wenn diese einen eindeutigen Name besitzen, dann kann man diese gezielt ansprechen und dann deren Eigenschaften anpassen. Und fertig.
Wie immer in einem solchen Forum bekommt man aber als Helfender alle Details erst nach und nach zur Kenntnis.
Manche Lösungsvorschläge sind daher manchmal zuerst suboptimal.
Zumal hier die Frage nach dem Fehler beim Erstellen der Buttons lag. Das lockt einen, zumindest mich diesmal, auf die falsche Spur.
Zu Deinem Beispiel:
Ich bin bis gerade eben davon ausgegangen, dass eine hochgeladene Beispielmappe auch funktioniert. Sonst wäre diese kein Beispiel. ;)
Wenn diese aber gewollt nicht funktioniert und 'nur' zur Veranschaulichung des Weges dient, dann schau ich mir Deinen Code sehr gern mit diesem Blickwinkel genauer an. :)
@boskobiati:
Danke für den aktuellen Stand, dann machen wir bis heute Abend halt erst einmal eine Pause.
Gruß Carsten