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
07.02.2018, 16:51 (Dieser Beitrag wurde zuletzt bearbeitet: 07.02.2018, 16:51 von BoskoBiati.)
Hi Carsten,
alles schon probiert, ändert sich nur die Fehlermeldung in Fehlernummer 438, heißt diese Schreibweise ist nicht gültig.
Der Gag ist, dass das Makro ab und zu ohne Probleme duchläuft, in ca. 80% der Fälle steigt es aber an irgendeiner Stelle (wenn einer der Buttons gefärbt werden soll) aussteigt
Gruß
Edgar
Meine Antworten sind freiwillig und ohne Gewähr!
Über Rückmeldungen würde ich mich freuen.
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
CB(loA).Object.BackColor = RGB(0, 0, 255)
CB(loA).Object.ForeColor = RGB(255, 255, 255)
ElseIf InStr(arrZahlen, loA) < 38 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("M2") = "Doppelklick hier!"
End With
Application.ScreenUpdating = True
Exit Sub
Fehler: MsgBox (Err.Number & " " & Err.Description & "--> Button " & loA & " " & strName & " " & arrZahlen)
End Sub
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
07.02.2018, 17:01 (Dieser Beitrag wurde zuletzt bearbeitet: 07.02.2018, 17:01 von DbSam.)
Ach, eben erst gesehen. Du hattest Deinen Beitrag nochmal angepasst.
Egal.
Bei mir läuft das Dingens ohne Probleme. Auch das hier:
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
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
test
End Sub
Was soll ich da noch nach einem Fehler suchen? Da müsste ich erst einen bauen.
(Starte mal testweise Dein Excel neu.)
Gruß Carsten
PS:
Ich kann mir das bei Bedarf heute Abend noch einmal anschauen
Ich habe die 'test'-Reihe verlängert und dann stirbt Excel den Heldentod.
Ich konnte es nur noch abschießen.
Vorschlag/Versuch:
Räume mal bitte am Schluss der Routine ordentlich auf und schmeiße auch das Array ordentlich weg, vorher in einer Schleife die Objekte auf Nothing setzen.
Da scheint etwas weiter zu leben ...
07.02.2018, 22:37 (Dieser Beitrag wurde zuletzt bearbeitet: 07.02.2018, 22:39 von DbSam.)
Hallo Edgar,
ich habe nochmal reingeschaut und etwas auf- und umgeräumt.
Denn da wurden einige Variablen eigentlich nicht benötigt, das Array mit den Buttons war total unnötig, etc.
Man hat also noch genau gesehen, dass da jemand noch nicht fertig ist.
Ohne genau zu wissen was Du da treibst und ohne viel Arbeit reinzustecken, habe ich mal den Code in einzelne und für mich lesbare Stücke zerlegt.
Probiere mal bitte aus:
Code:
Option Explicit
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
cancel = True
Range("M2") = "Doppelklick hier!"
test
End Sub
Sub test()
On Error GoTo Er
Dim i As Integer
Dim strCaption As String
Dim myValues As String
Dim sh As Worksheet
Set sh = Sheets("Tabelle2")
DeleteAllCommandButtons sh
myValues = CreateMyValues
With sh
.Cells(1, 2).FormulaLocal = "=INDEX(Liste!1:1;ZUFALLSBEREICH(0;5)*2+1)"
.Cells(1, 2).Value = .Cells(1, 2).Value
For i = 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)"
strCaption = .Cells(1, 1)
CreateMyButton sh, strCaption, myValues, i
Next
.Range("a1").Clear
.Range("M2") = "Doppelklick hier!"
End With
Ex:
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Set sh = Nothing
Exit Sub
Er:
Application.Cursor = xlDefault
Application.ScreenUpdating = True
MsgBox Err.Number & " " & Err.Description & "--> Button " & i & " " & strCaption & " " & myValues
Resume Ex
End Sub
Private Sub DeleteAllCommandButtons(ByVal sh As Worksheet)
On Error GoTo Er
Dim shp As Shape, b As Boolean
'aktuellen Status merken, dann ausschalten:
b = Application.ScreenUpdating
Application.ScreenUpdating = False
'nur CommandButtons löschen ...
'ansonsten halt über den Name, wenn spezifiziert ...
For Each shp In sh.Shapes
If UCase(shp.OLEFormat.progID) = UCase("Forms.CommandButton.1") Then
shp.Delete
End If
Next
'Erzwingen des einmaligen Neuzeichnens:
Application.ScreenUpdating = True
DoEvents
'alten Status setzen:
Application.ScreenUpdating = b
Ex:
Exit Sub
Er:
MsgBox Err.Number & vbNewLine & Err.Description, vbCritical, "Sub DeleteAllCommandButtons"
Resume Ex
Resume Next
End Sub
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, i)
Case Is < 27
.Object.BackColor = RGB(0, 0, 255)
.Object.ForeColor = RGB(255, 255, 255)
Case 28 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
Private Sub ArrangeMyObject(ByVal o As Object, i As Integer)
On Error GoTo Er
If o Is Nothing Then Exit Sub
Select Case i
Case 0 To 5
o.Top = 30
o.Left = 259 + (i - 1) * 69
Case 6 To 11
o.Top = 90
o.Left = 259 + (i - 6) * 69 - 34
Case 12 To 18
o.Top = 150
o.Left = 259 + (i - 13) * 69
Case 19 To 26
o.Top = 210
o.Left = 259 + (i - 20) * 69 - 34
Case 27 To 35
o.Top = 270
o.Left = 259 + (i - 29) * 69
Case 36 To 43
o.Top = 330
o.Left = 259 + (i - 37) * 69 - 34
Case 44 To 50
o.Top = 390
o.Left = 259 + (i - 45) * 69
Case 51 To 56
o.Top = 450
o.Left = 259 + (i - 51) * 68.25 - 34
Case Else
o.Top = 510
o.Left = 259 + (i - 57) * 68.25
End Select
Ex:
Exit Sub
Er:
MsgBox Err.Number & vbNewLine & Err.Description, vbCritical, "Sub ArrangeMyObject"
Resume Ex
End Sub
Das ist sicher nicht optimal, aber in etwa so würde ich vorgehen.
Wobei ich das vielleicht noch weiter auslagern würde ...
Private Sub worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
If TargetAddress = "$M$2" Then
cancel = True
On Error GoTo XL90
With Tabelle1
sn = Tabelle2.Cells(1).CurrentRegion
.[K1:K61] = "=rand()"
sp = [index(rank(T_OLE!K1:K61,T_OLE!K1:K61),)]
.[K1:K61].ClearContents
y = Int(6 * Rnd()) + 1
For j = 1 To UBound(sn)
If sn(j, y) = "" Then Exit For
Next
For jj = 1 To 61
With .OLEObjects.Add("Forms.CommandButton.1")
.Name = "C_" & Format(jj, "00")
.Object.Caption = sn(Int((j - 1) * Rnd()) + 2, y)
.Height = 60
.Width = 68.25
.Top = 510
.Left = 259 + (jj Mod 6) * 69
If jj < 57 Then .Top = 30 + 60 * (jj \ 6)
If jj < 57 Then .Left = 259 + (jj Mod 6) * 69
End With
Next
For j = 1 To 14
With .OLEObjects("C_" & sp(j, 1)).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
danke für Deine Bemühungen. Wie schon gesagt, Dein erster Entwurf läuft. Warum er bei mir den gleichen Code angemeckert hat, keine Ahnung. Den neuen Code habe ich mal ausprobiert, er läuft einmal durch, beim zweiten Mal hängt sich Excel auf, ich muß mal testen, was da passiert.
Hintergrund des Ganzen ist ein Spiel, bei dem das Spielfeld aus nebeneinander angeordneten Sechseckigen Feldern besteht, auf dem bestimmte Dinge verteilt sind. Hier geht es darum ein neues Spielfeld zufällig zu erstellen. Anhand des Programms werden die Sechsecke eben neu angeordnet und belegt.
@snb, läuft zwar, entspricht aber nicht der gewünschten Anordnung. Ich werde es mir noch in Ruhe ansehen.
Gruß
Edgar
Meine Antworten sind freiwillig und ohne Gewähr!
Über Rückmeldungen würde ich mich freuen.
CB_Forum_070218.xlsx (Größe: 10,74 KB / Downloads: 8)
