Option Explicit
Sub TestErzeugeSchaltfläche()
Rem in der Arbeitsmappe besteht eine leere Tabelle(1)-Kalkulation u. leere Tabelle(3)-Angebot
Dim x As Long
Rem bei Bedarf erst Bestand löschen
For x = ActiveSheet.Buttons.Count To 1 Step -1
ActiveSheet.Buttons(x).Delete
Next x
ActiveSheet.Buttons.Add(0, 0, 160, 20).Select
With Selection
.OnAction = "MakroÜbernahmeWenn"
.Characters.Text = "Zelle daneben übernehmen"
End With
End Sub
Sub TestErzeugeCheckboxen()
Rem in der Arbeitsmappe besteht eine leere Tabelle(1)-Kalkulation u. leere Tabelle(3)-Angebot
Dim Spalte As Long
Dim chkIndex As Long
Dim Zeile As Long
Dim chkName As String
Dim x As Long
Rem bei Bedarf erst Bestand löschen
For x = ActiveSheet.CheckBoxes.Count To 1 Step -1
ActiveSheet.CheckBoxes(x).Delete
Next x
Rem welche Zeilen, ggf. springen
For Zeile = 4 To 6 Step 2
Rem welche Spalten, ggf. springen
For Spalte = 1 To 4 Step 2
Columns(Spalte).ColumnWidth = 3
chkIndex = chkIndex + 1
ActiveSheet.CheckBoxes.Add( _
Cells(Zeile, Spalte).Left, _
Cells(Zeile, Spalte).Top, _
Cells(Zeile, Spalte).Width, _
Cells(Zeile, Spalte).Height).Select
With Selection
.Characters.Text = ""
.PrintObject = False
.Name = "K" & Cells(Zeile, Spalte).Address
End With
Rem zum Test halt einen einen Text in die Zelle daneben
Cells(Zeile, Spalte + 1).Formula = _
Format(Spalte, "#0")
Cells(Zeile, Spalte + 1).Formula = _
Cells(Zeile, Spalte + 1).Formula & " . "
Cells(Zeile, Spalte + 1).Formula = _
Cells(Zeile, Spalte + 1).Formula & _
Format(Zeile, "#0" & " Mein Text")
Next Spalte
Next Zeile
End Sub
Sub MakroÜbernahmeWenn()
Dim x As Long
Dim sName As String
Dim Quelle As Range
For x = 1 To ActiveSheet.CheckBoxes.Count
If ActiveSheet.CheckBoxes(x).Value = 1 Then
sName = ActiveSheet.CheckBoxes(x).Name
sName = Replace(sName, "K", "")
Set Quelle = Range(sName)
Set Quelle = Quelle.Offset(0, 1)
Quelle.Copy Destination:=Tabelle3.Range(Quelle.Address)
End If
Next x
End Sub