07.02.2018, 16:04
Hi zusammen,
heute habe ich auch mal ein Problem:
Der folgende Code läuft einwandfrei durch:
Aktiviere ich eine der Zeilen, mit der die Farbeigenschaften der Commandbuttons geändert werden (Zwischen den gestrichelten Linien), läuft der Code regelmäßig in einen Fehler, den ich aber nicht eingrenzen kann. Vielleicht kann jemand mir weiterhelfen. Die beiden Tabellen, die dazu gebraucht werden hänge ich mal an.
Der Code in der Tabelle zum Starten ist dieser:
[attachment=16036]
heute habe ich auch mal ein Problem:
Der folgende Code läuft einwandfrei durch:
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, loA) < 27 Then
'.OLEObjects(CB(loA)).Object.BackColor = RGB(0, 0, 255)
'.OLEObjects("CommandButton" & loA).Object.ForeColor = RGB(255, 255, 255)
ElseIf InStr(arrZahlen, loA) < 38 Then
'.OLEObjects("CommandButton" & loA).Object.BackColor = RGB(200, 100, 0)
Else
'.OLEObjects("CommandButton" & 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("M2") = "Doppelklick hier!"
End With
Application.ScreenUpdating = True
Exit Sub
Fehler: MsgBox (Err.Number & " " & Err.Description & "--> Button " & loA & " " & strName & " " & arrZahlen)
End Sub
Aktiviere ich eine der Zeilen, mit der die Farbeigenschaften der Commandbuttons geändert werden (Zwischen den gestrichelten Linien), läuft der Code regelmäßig in einen Fehler, den ich aber nicht eingrenzen kann. Vielleicht kann jemand mir weiterhelfen. Die beiden Tabellen, die dazu gebraucht werden hänge ich mal an.
Der Code in der Tabelle zum Starten ist dieser:
Code:
Private Sub worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
If Target.Count > 1 Or Intersect(Target, Range("M2")) Is Nothing Then Exit Sub
Range("M2") = "Doppelklick hier!"
test
End Sub
[attachment=16036]