Excel Makro - Button erstellen in Zelle A, Zählung der Klicks in Zelle B?

1 Antwort

daCypher
04.08.2023, 10:44

Die einfachste Variante wäre, wenn du "Drehfelder" in deine Tabelle einfügst. Das sind Steuerelemente mit einem Knopf nach oben und einem Knopf nach unten und je nachdem auf welchen du klickst, wird hoch oder runter gezählt. Du kannst ein Drehfeld mit einer Zelle verbinden, indem du einen rechtsklick auf das Drehfeld machst, dann auf "Steuerelement formatieren..." klickst und im Reiter "Steuerung" eine Zelle in das Feld "Zellverknüpfung" einträgst.

Der Nachteil dieser Drehfelder ist, dass nicht einstellen kann, dass nur der Button für hochzählen angezeigt werden soll.

Die Variante mit einfachen Buttons und VBA-Code hat aber auch Nachteile:

  • Falls du die Excel-Tabelle z.B. per Mail versenden willst, wird die Mail in den meisten Fällen abgelehnt, weil Outlook z.B. gar keine Office-Dateien mit Makros zulässt.
  • Die Buttons haben leider so einen großen Abstand zwischen Text und Rand, dass man die Beschriftung nicht mehr sieht, wenn man den Button in eine Zelle reinquetscht
  • Alle Steuerelemente lassen sich frei positionieren, so dass man z.B. nicht sagen kann, dass eine bestimmte Zelle ein Button sein soll. Viele Buttons per Hand irgendwo hinzuschieben ist ziemlich viel Fummelkram
  • Man kann in VBA leider nicht sagen, dass alle Buttons eine gemeinsame Ereignisprozedur aufrufen sollen, sondern jeder Button kriegt seine eigene Prozedur (allerdings kann man von da aus natürlich eine gemeinsame Prozedur aufrufen)

Naja, ich hab dir trotzdem mal was in VBA gebaut, was dir in die Zellen A2:A100 jeweils einen Button mit einem "+" reinmacht (eigentlich sind es Labels und keine Buttons, damit man das + auch sehen kann) und wenn man raufklickt, wird in Spalte V jeweils der Wert, der zu dem Button gehört, erhöht.

  • Öffne den VBA-Editor (Alt + F11)
  • Mache in dem Projektexplorer einen Doppelklick auf deine Tabelle
  • Rechts geht ein Codefenster auf. Füge da diesen Code ein:
Option Explicit

Public Sub Buttons_erstellen()
    Dim code As String
    code = vbCrLf & "'##### Automatisch generierter Code für die Buttons #####" & vbCrLf
    
    Dim i As Integer
    For i = 2 To 100
        Dim ole As OLEObject
        Set ole = OLEObjects.Add( _
            ClassType:="Forms.Label.1", _
            Left:=15, _
            Top:=(i - 1) * 15, _
            Width:=30, _
            Height:=15 _
        )
        ole.Name = "lblA" & i
        Dim lbl As MSForms.label
        Set lbl = ole.Object
        lbl.Caption = "+"
        lbl.SpecialEffect = fmSpecialEffectRaised
        lbl.BackColor = &H8000000F
        lbl.TextAlign = fmTextAlignCenter
        
        code = code _
             & vbCrLf _
             & "Private Sub lblA" & i & "_Click()" & vbCrLf _
             & "    Label_Click lblA" & i & vbCrLf _
             & "End Sub" & vbCrLf _
             & vbCrLf _
             & "Private Sub lblA" & i & "_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)" & vbCrLf _
             & "    Label_MouseDown lblA" & i & ", Button, Shift, X, Y" & vbCrLf _
             & "End Sub" & vbCrLf _
             & vbCrLf _
             & "Private Sub lblA" & i & "_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)" & vbCrLf _
             & "    Label_MouseUp lblA" & i & ", Button, Shift, X, Y" & vbCrLf _
             & "End Sub" & vbCrLf
    Next i
    
    Dim modul As Object
    Set modul = ThisWorkbook.VBProject.VBE.ActiveCodePane.CodeModule
    modul.InsertLines modul.CountOfLines + 1, code
End Sub

Sub Buttons_loeschen()
    Shapes.SelectAll
    Selection.Delete
End Sub

Private Sub Label_Click(Sender As Object)
    Dim Zelle As Range
    Set Zelle = Range("V" & Mid(Sender.Name, 5))
    Zelle.Value = Zelle.Value + 1
End Sub

Private Sub Label_MouseDown(Sender As Object, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Sender.SpecialEffect = fmSpecialEffectSunken
End Sub

Private Sub Label_MouseUp(Sender As Object, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Sender.SpecialEffect = fmSpecialEffectRaised
End Sub
  • Klicke in die Funktion "Buttons_erstellen()" und drücke F5

Nicht wundern, wenn die Funktion durchgelaufen ist, sind untendrunter haufenweise neue Subs für die ganzen Buttons