VBA Backcolor in CommandButton führt zu Fehlern

[DbSam]

@snb:
Vergessen zu schreiben:

Mein Blickwinkel zu Edgars Problem war:
Man kann nicht immer den Code des Fragestellers komplett so umbauen, dass er sich gar nicht wiederfindet.
Deshalb habe ich das Coding von Edgar nur thematisch aufgeteilt. Diese einzelnen Schritte kann man später auch einzeln optimieren.

[Kuwer]

Auch Hallo,

ich finde es brutal, ActiveX-CommandButtons zu nehmen. Hier mal ein Beispiel mit der Autoform Rechteck: (Da könnte man natürlich noch viel mehr formatieren und gestalten.)

Sub test_Kuwer()
   Dim loA As Long
   Dim loB As Long
   Dim lozahl As Long
   Dim loZahl2 As Long
   Dim loC As Long
   Dim CB As Shape
   Dim strB As String
   Dim strName As String
   Dim arrZahlen, arrZahlen2(13)
With Sheets("Tabelle2")
   Application.ScreenUpdating = False
   .DrawingObjects.Delete
   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 = .Shapes.AddShape(msoShapeRectangle, 20, 20, 68.25, 56)
       CB.ThreeD.ContourWidth = 0.2
       CB.TextFrame2.TextRange.Text = strName
       CB.Line.ForeColor.RGB = RGB(192, 192, 192)
       CB.Fill.ForeColor.RGB = RGB(192, 192, 192)
       CB.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
       strB = Format(loA, "00")
       
       If InStr(arrZahlen, strB) <> 0 Then
           CB.Fill.ForeColor.RGB = RGB(0, 0, 255)
           CB.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
'----------------------
           If InStr(arrZahlen, loA) < 27 Then
               CB.Fill.ForeColor.RGB = RGB(0, 0, 255)
               CB.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
           ElseIf InStr(arrZahlen, loA) < 38 Then
               CB.Fill.ForeColor.RGB = RGB(200, 100, 0)
           Else
               CB.Fill.ForeColor.RGB = RGB(100, 100, 100)
           End If
       End If
' -------------------------------
       
       If loA < 6 Then
           
           CB.Top = 30
           CB.Left = 259 + (loA - 1) * 69
       ElseIf loA < 12 Then
           CB.Top = 90
           CB.Left = 259 + (loA - 6) * 69 - 34
       ElseIf loA < 19 Then
           CB.Top = 150
           CB.Left = 259 + (loA - 13) * 69
       ElseIf loA < 27 Then
           CB.Top = 210
           CB.Left = 259 + (loA - 20) * 69
       ElseIf loA < 36 Then
           CB.Top = 270
           CB.Left = 259 + (loA - 29) * 69
       ElseIf loA < 44 Then
           CB.Top = 330
           CB.Left = 259 + (loA - 37) * 69 - 34
       ElseIf loA < 51 Then
           CB.Top = 390
           CB.Left = 259 + (loA - 45) * 69
       ElseIf loA < 57 Then
           CB.Top = 450
           CB.Left = 259 + (loA - 51) * 68.25 - 34
       Else
           CB.Top = 510
           CB.Left = 259 + (loA - 57) * 68.25
       End If
   Next
    .Range("a1").Clear
    .Range("M2") = "Doppelklick hier!"
End With

Application.ScreenUpdating = True
Exit Sub
Fehler: MsgBox (Err.Number & "   " & Err.Description & "--> Button " & loA & " " & strName & " " & arrZahlen)
End Sub

Gruß Uwe

[snb]

@DBsam

Mien Beispiel läuft hier makellos.
Was hast du verpasst ?? ;)

[DbSam]

@snb:

Hhmm, weiß nicht. Wahrscheinlich falsch gehandhabt.

Ich habe es jetzt noch einmal herunter geladen und lokal abgespeichert.
Nun läuft es und da macht die Ansicht Deines Code wieder Spaß. Danke.
Ich guck ...


Gruß Carsten

[DbSam]

@Kuwer:
Oooch, brutal - Das klingt so brutal ...  :D

Eigentlich haben wir uns aktuell dem eigentlichen Problem so langsam genähert:

• Vermeidung von Löschung und Neuerstellung von was auch immer. Seien es nun brutale Buttons, Rechtecke, Bilder oder sonstwas.
  
• Vermeidung der Vermischung von 'VBA-Gehampel' mit 'Formelgehampel'
  
• Optimierung, bzw. bessere Kontrolle bei der Generierung der Anzahl der farbigen 'WasAuchImmers'.
  

So jedenfalls mein derzeitiger Kenntnisstand.



Gruß Carsten

[BoskoBiati]

Hi Uwe,

das ist mal ein Wort. Das läuft ja in Nullkommanichts ab. :23:

Habe ich so übernommen. Danke.

[DbSam]

Ok.
Wie geht es weiter?

Edit:
Alle aufgeführten Fehler sind noch enthalten.

[BoskoBiati]

Hi,

ich habe den Code von Uwe übernommen und noch ein paar Kleinigkeiten bereinigt. Für mich ist das jetzt erst einmal die endgültige Version, die wohl auch so zum Einsatz kommt. Mit der Variante von snb muß ich mich auseinandersetzen, wenn ich Zeit habe, was noch ein paar Tage dauern kann (Fasnacht).

[DbSam]

Gut, dann lege ich mich wieder hin.  :D


Gruß Carsten


PS:
Was noch zu erledigen ist:

• Es werden immer noch unnötig Shapes erstellt, anstatt nur deren Eigenschaften zu verändern
  
• Die Ermittlung und Zuweisung der Farben funktioniert nicht zuverlässig. (Teste mal mehrmals ...)
  (Deswegen würde ich solche Dinge auslagern und extra behandeln.)
  
• Es gibt immer noch ein Vermischung von Formeln und VBA-Gehampel
  
• Unnötige Variablen und Zuweisungen müssen noch entfernt werden
  

[BoskoBiati]

Hi Carsten,

die Zuweisung der Farben passt mit diesem Code:

Code:

InStr(arrZahlen, Format(loA, "00"))

der Rest ist momentan nicht so dringend, es geht momentan nur darum, uns die Gestaltung des Spielplans zu vereinfachen. Da das Spiel mehrere Stunden dauert, wird es maximal zweimal am Abend und ggf. dreimal an einem Sonntag gespielt, d.h. die Datei läuft ca. 7x pro Woche :19: