Vielen Dank für Eure Beiträge, habe mittlerweile noch einen anderen Hinweis erhalten, den ich Euch auch zur Verfügung stellen möchte:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub MakeOptButtons()
Dim objOpt As Object
Dim lngRow As Long, lngStart As Long, lngRowCount As Long
Dim intCol As Integer, intStart As Integer, intCount As Integer
Dim lngCalculation As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lngCalculation = .Calculation
.Calculation = xlCalculationManual
.Cursor = xlWait
End With
lngStart = 6 ' Startzeile
lngRowCount = 80 ' Anzahl Zeilen
intStart = 2 ' Startspalte
intCount = 8 ' Buttons pro Zeile
For lngRow = lngStart To lngStart + lngRowCount
For intCol = intStart To intStart + intCount
Set objOpt = ActiveSheet.OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
Left:=Cells(lngRow, intCol).Left + 1, Top:=Cells(lngRow, intCol).Top + 1, _
Width:=Cells(lngRow, intCol).Width - 1, Height:=Cells(lngRow, intCol).Height - 1)
With objOpt
.Object.Caption = CStr("")
.Object.GroupName = ActiveSheet.Name & "_Grp" & lngRow
.LinkedCell = Cells(lngRow, intCol).Address
.Object.Value = (intCol = intStart)
End With
Set objOpt = Nothing
Next
Next
ErrExit:
If Err.Number > 0 Then
MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
Err.Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = lngCalculation
.Cursor = xlDefault
End With
End Sub
Grüße
Romy100
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP