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: