04.08.2025, 14:09
Liebe Leserin, lieber Leser,
für die schnelle Auswahl eines oder mehrerer Elemente aus einem Elementensatz könnte man bequem eine Auswahlbox mit Radio- oder Checkboxen nutzen.
Hierzu gibt es hier im Forum im Bereich "Beispiele und Workshops" ja auch schon Beiträge, z.B. der Umbau einer Inputbox usw.
Wer kein API-Freund ist und lieber bei den Excelmöglichkeiten bleiben möchte, der kann sich ja eine Userform dafür hernehmen.
Heute wollen wir uns für diese Aufgabe eine dynamische Userform bauen, die programmatisch erstellt, angezeigt und nach Benutzung wieder gelöscht wird.
Der nachfolgende Beispielcode erstellt eine Auswahlbox mit folgenden Eigenschaften:
Zur besseren Demonstration verschiedenster Versionen lade Dir die anliegende Datei herunter....
Dynamische Userform.xlsb (Größe: 41,07 KB / Downloads: 5)
für die schnelle Auswahl eines oder mehrerer Elemente aus einem Elementensatz könnte man bequem eine Auswahlbox mit Radio- oder Checkboxen nutzen.
Hierzu gibt es hier im Forum im Bereich "Beispiele und Workshops" ja auch schon Beiträge, z.B. der Umbau einer Inputbox usw.
Wer kein API-Freund ist und lieber bei den Excelmöglichkeiten bleiben möchte, der kann sich ja eine Userform dafür hernehmen.
Heute wollen wir uns für diese Aufgabe eine dynamische Userform bauen, die programmatisch erstellt, angezeigt und nach Benutzung wieder gelöscht wird.
Der nachfolgende Beispielcode erstellt eine Auswahlbox mit folgenden Eigenschaften:
- Einfach- oder Mehrfachauswahl mittels Radiobuttons oder Checkboxen
- Elementübergabe mittels String, Array, Range oder Objekt
- Anzeigeposition zentriert, an vorgegebener Position oder an Mausposition z.B. bei Rechtsklick
- Anzeige mit oder ohne Schaltflächen, für eine kleine Box mit schneller Auswahl
- und weiteres
Zur besseren Demonstration verschiedenster Versionen lade Dir die anliegende Datei herunter....
Dynamische Userform.xlsb (Größe: 41,07 KB / Downloads: 5)
Code:
' #### "Zugriff auf das VBA-Projektobjektmoddel vertrauen" muss im Trustcenter aktiviert sein ####
' Auswahl zwischen mehreren Begriffen auf der Basis einer temporären UserForm
' entweder als Radio-Button (nur ein Eintrag auswählbar) oder als Checkbox (mehrere Einträge auswählbar)
' Beim Aufruf von "GetAuswahl" sind folgende Parameter mitzugeben:
'
' 1: Ein Array oder ein kommagetrennter String oder ein Excel-Range mit den Begriffen
' alle anderen Parameter sind optional
' 2. Titeltext (Caption der Userform)
' 3: MultiSelect:
' True Anzeige als Checkbox-Buttons
' False Anzeige als Radio-Buttons
' 4: Prompt: Default: "Bitte triff Deine Auswahl!"
' optional: ein beliebiger Text
' 5, 6: Position
' einer 0 Anzeige zentriert
' beide >0 Anzeige der Userform an dieser Position
' beide -1 Anzeige an der Mausposition
' Rückgabe: Kommagetrennter String, der durch den User durch Split bei Bedarf in ein Aray transferiert werden kann
Option Explicit
Option Compare Text
Option Base 1
' Private Const csPrompt As String = "Bitte triff Deine Auswahl!" ' Wenn leer, dann kein Prompt
Private Const csPrompt As String = "" ' Wenn leer, dann kein Prompt, kein Frame
Private Const ccUmrech As Currency = 5.5 ' Zur Ermittlung der UF-Breite anhand des Textes
Private Const csSep As String = ","
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Public gvErg() As Variant ' gvErg(1) ist die Rückgabevariable
Public Function GetAuswahl(ByVal Items As Variant, Optional ByVal Titel As String, _
Optional ByVal MultiSel As Boolean, _
Optional ByVal MsgTxt As String, _
Optional ByVal xPos As Long, Optional ByVal yPos As Long, _
Optional NoButtons As Boolean) As Variant
Dim oUF As Object
Dim PT As POINTAPI
Dim oFrm As Object
Dim bFrame As Boolean
Dim sCtrlTyp As String
Dim sCode As String
Dim sUFName As String
Dim iCtrPos As Long, iAnz As Long, iNr As Long
Dim iUFBreite As Long
Dim yPosInUF As Long
Const ciBtnLinks As Long = 5
Const ciBtnBreit As Long = 65
Const ciBtnAbst As Long = 15
If IsObject(Items) Then
iAnz = Items.Count
ElseIf IsArray(Items) Then
iAnz = UBound(Items)
Else
If Items = vbNullString Then Exit Function
Items = Split(csSep & Items, csSep)
iAnz = UBound(Items)
End If
ReDim gvErg(iAnz)
bFrame = True ' Mit oder ohne Gruppenrahmen
yPosInUF = 5
' Userformbreite ermitteln
If MultiSel Then
iUFBreite = (ciBtnLinks + ciBtnBreit) * 2 + ciBtnAbst + 12
Else
iUFBreite = ciBtnLinks * 2 + ciBtnBreit + 40
End If
If Len(Titel) * ccUmrech * 1.2 > iUFBreite Then iUFBreite = Len(Titel) * ccUmrech * 1.2
If MsgTxt = "" Then MsgTxt = csPrompt
If Len(MsgTxt) * ccUmrech > iUFBreite Then iUFBreite = Len(MsgTxt) * ccUmrech
For iNr = 1 To iAnz
If Len(Items(iNr)) * ccUmrech > iUFBreite Then iUFBreite = Len(Items(iNr)) * ccUmrech
Next iNr
' Userform erstellen
If Titel = "" Then Titel = Split(ActiveWorkbook.Name, ".")(0)
Set oUF = ThisWorkbook.VBProject.VBComponents.Add(3)
With oUF
.Properties("Width") = iUFBreite ' Breite der Userform setzen
.Properties("Caption") = Titel
End With
' Label anlegen
If MsgTxt <> "" Then
With oUF.Designer.Controls.Add("Forms.Label.1")
.Name = "Label1"
.Caption = MsgTxt
.Left = ciBtnLinks
.Top = yPosInUF
.Width = iUFBreite - 20
.Height = 10
.TextAlign = 2 'fmTextAlignCenter
.Font.Bold = True
yPosInUF = yPosInUF + .Height + 5
End With
Else
bFrame = False
End If
' Optional einen Frame für die Controls anlegen
If bFrame = True Then
Set oFrm = oUF.Designer.Controls.Add("Forms.Frame.1")
With oFrm
.Name = "Frame1"
.Left = ciBtnLinks
.Top = yPosInUF
.Width = iUFBreite - 20
End With
iCtrPos = 5 ' Beginnposition Controls
Else
Set oFrm = oUF.Designer ' Keinen Frame anlegen
iCtrPos = yPosInUF ' Beginnposition Controls
End If
' Mehrere gleichartige Controls anlegen
sCtrlTyp = IIf(MultiSel, "CheckBox", "OptionButton")
For iNr = 1 To iAnz
With oFrm.Controls.Add("Forms." & sCtrlTyp & ".1", sCtrlTyp & iNr, True)
.Name = sCtrlTyp & iNr
.Caption = Items(iNr)
.Left = ciBtnLinks
.Top = iCtrPos
.Width = iUFBreite - 20
.Height = 15
iCtrPos = iCtrPos + .Height + 5
' Code dazu
sCode = sCode _
& "Private Sub " & .Name & "_Click()¶" _
& " ControlClick " & .Name & ", " & iNr & "¶" _
& "End Sub¶¶"
End With
Next iNr
' Sammel-Sub Code für die Controls schreiben
sCode = sCode & "Private Sub ControlClick(oCtrl as Object, iNr as Integer)¶"
If MultiSel Then
sCode = sCode & " gvErg(iNr) = IIf(oCtrl.Value = True, oCtrl.Caption, '')¶""
Else
sCode = sCode _
& " gvErg(1) = oCtrl.Caption¶" _
& " Unload Me¶"
End If
sCode = sCode & "End Sub¶¶"
If bFrame Then oFrm.Height = iCtrPos ' Framehöhe anpassen an Controlanzahl
yPosInUF = yPosInUF + (iAnz * 20) + IIf(bFrame, 10, 5) ' Position für die Buttons festlegen
If NoButtons = True Then GoTo SetzeCode ' Es werden keine Buttons gewünscht, damit UF klein bleibt
' Abbrechen-Button erstellen
With oUF.Designer.Controls.Add("Forms.CommandButton.1")
.Name = "Abbrechen"
.Caption = "Abbrechen"
.Left = IIf(MultiSel, ciBtnLinks + ciBtnBreit + ciBtnAbst, iUFBreite \ 2 - ciBtnBreit \ 2 - 4)
.Top = yPosInUF
.Width = ciBtnBreit
.Height = 25
.BackColor = RGB(255, 200, 200)
' Code dazu
sCode = sCode _
& "Private Sub " & .Name & "_Click()¶" _
& " gvErg(1)=vbNullString¶" _
& " Unload Me¶" _
& "End Sub¶¶"
End With
If MultiSel Then
sCode = "Dim bAll as Boolean¶¶" & sCode
' Übernahme-Button erstellen
With oUF.Designer.Controls.Add("Forms.CommandButton.1")
.Name = "Uebernehmen"
.Caption = "Übernehmen"
.Left = ciBtnLinks
.Top = yPosInUF
.Width = ciBtnBreit
.Height = 25
.BackColor = RGB(100, 255, 100)
' Code dazu
sCode = sCode _
& "Private Sub " & .Name & "_Click()¶" _
& " Dim i As Long, Werte As String¶¶" _
& " For i = 1 To UBound(gvErg)¶" _
& " If gvErg(i) <> vbNullString Then Werte = Werte & gvErg(i) & ','¶" _"
& " Next i¶" _
& " If Werte = vbNullString Then¶" _
& " With Label1¶" _
& " .Caption = 'Keine Auswahl getroffen'¶" _"
& " .TextAlign = fmTextAlignCenter¶" _
& " .BackColor = RGB(255,255,100)¶" _
& " .Font.Bold = True¶" _
& " End With¶" _
& " Else¶" _
& " gvErg(1) = Left(Werte, Len(Werte) - 1)¶¶" _
& " Unload Me¶" _
& " End If¶" _
& "End Sub¶¶"
End With
' SetzeAlle-Button erstellen
With oUF.Designer.Controls.Add("Forms.CommandButton.1")
.Name = "ButtonAlle"
.Caption = "Alle auswählen"
.Left = ciBtnLinks
.Top = yPosInUF + 35
.Width = ciBtnBreit
.Height = 25
.BackColor = RGB(255, 255, 100)
' Code dazu
sCode = sCode _
& "Private Sub " & .Name & "_Click()¶" _
& " Dim i As Long, iChk As Long¶¶" _
& " bAll = Not bAll¶" _
& " iChk = bAll And 1¶" _
& " For i = 1 To UBound(gvErg)¶" _
& " gvErg(i) = Controls('" & sCtrlTyp & "' & i).Caption¶" _
& " Controls('" & sCtrlTyp & "' & i).Value = iChk¶" _
& " Next i¶" _
& "End Sub¶¶"
End With
yPosInUF = yPosInUF + 40
End If
yPosInUF = yPosInUF + 40
SetzeCode:
' Erstellten Code ins Modul einfügen
oUF.CodeModule.InsertLines 1, Replace(Replace(sCode, "'", Chr(34)), "¶", vbLf)
oUF.Properties("Height") = yPosInUF + 25
' Userform positionieren
If xPos < 0 And yPos < 0 Then
GetCursorPos PT ' Mausposition holen
xPos = PT.x / 1.67: yPos = PT.y / 1.67
End If
If xPos > 0 And yPos > 0 Then
oUF.Properties("Left") = xPos
oUF.Properties("Top") = yPos
End If
' Userform anzeigen
Set oUF = CallByName(UserForms, "Add", VbMethod, oUF.Name)
sUFName = oUF.Name
oUF.Show
GetAuswahl = Replace(gvErg(1), ",", csSep) ' Auswahl zurückgeben
' Exit Function ' Aktivieren, wenn Userform erhalten bleiben soll
' Userform entfernen
With ActiveWorkbook.VBProject
For Each oUF In .VBComponents
If oUF.Type = 3 And oUF.Name Like sUFName Then
.VBComponents.Remove oUF
End If
Next oUF
End With
End Function
' Auswahl zwischen mehreren Begriffen auf der Basis einer temporären UserForm
' entweder als Radio-Button (nur ein Eintrag auswählbar) oder als Checkbox (mehrere Einträge auswählbar)
' Beim Aufruf von "GetAuswahl" sind folgende Parameter mitzugeben:
'
' 1: Ein Array oder ein kommagetrennter String oder ein Excel-Range mit den Begriffen
' alle anderen Parameter sind optional
' 2. Titeltext (Caption der Userform)
' 3: MultiSelect:
' True Anzeige als Checkbox-Buttons
' False Anzeige als Radio-Buttons
' 4: Prompt: Default: "Bitte triff Deine Auswahl!"
' optional: ein beliebiger Text
' 5, 6: Position
' einer 0 Anzeige zentriert
' beide >0 Anzeige der Userform an dieser Position
' beide -1 Anzeige an der Mausposition
' Rückgabe: Kommagetrennter String, der durch den User durch Split bei Bedarf in ein Aray transferiert werden kann
Option Explicit
Option Compare Text
Option Base 1
' Private Const csPrompt As String = "Bitte triff Deine Auswahl!" ' Wenn leer, dann kein Prompt
Private Const csPrompt As String = "" ' Wenn leer, dann kein Prompt, kein Frame
Private Const ccUmrech As Currency = 5.5 ' Zur Ermittlung der UF-Breite anhand des Textes
Private Const csSep As String = ","
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Public gvErg() As Variant ' gvErg(1) ist die Rückgabevariable
Public Function GetAuswahl(ByVal Items As Variant, Optional ByVal Titel As String, _
Optional ByVal MultiSel As Boolean, _
Optional ByVal MsgTxt As String, _
Optional ByVal xPos As Long, Optional ByVal yPos As Long, _
Optional NoButtons As Boolean) As Variant
Dim oUF As Object
Dim PT As POINTAPI
Dim oFrm As Object
Dim bFrame As Boolean
Dim sCtrlTyp As String
Dim sCode As String
Dim sUFName As String
Dim iCtrPos As Long, iAnz As Long, iNr As Long
Dim iUFBreite As Long
Dim yPosInUF As Long
Const ciBtnLinks As Long = 5
Const ciBtnBreit As Long = 65
Const ciBtnAbst As Long = 15
If IsObject(Items) Then
iAnz = Items.Count
ElseIf IsArray(Items) Then
iAnz = UBound(Items)
Else
If Items = vbNullString Then Exit Function
Items = Split(csSep & Items, csSep)
iAnz = UBound(Items)
End If
ReDim gvErg(iAnz)
bFrame = True ' Mit oder ohne Gruppenrahmen
yPosInUF = 5
' Userformbreite ermitteln
If MultiSel Then
iUFBreite = (ciBtnLinks + ciBtnBreit) * 2 + ciBtnAbst + 12
Else
iUFBreite = ciBtnLinks * 2 + ciBtnBreit + 40
End If
If Len(Titel) * ccUmrech * 1.2 > iUFBreite Then iUFBreite = Len(Titel) * ccUmrech * 1.2
If MsgTxt = "" Then MsgTxt = csPrompt
If Len(MsgTxt) * ccUmrech > iUFBreite Then iUFBreite = Len(MsgTxt) * ccUmrech
For iNr = 1 To iAnz
If Len(Items(iNr)) * ccUmrech > iUFBreite Then iUFBreite = Len(Items(iNr)) * ccUmrech
Next iNr
' Userform erstellen
If Titel = "" Then Titel = Split(ActiveWorkbook.Name, ".")(0)
Set oUF = ThisWorkbook.VBProject.VBComponents.Add(3)
With oUF
.Properties("Width") = iUFBreite ' Breite der Userform setzen
.Properties("Caption") = Titel
End With
' Label anlegen
If MsgTxt <> "" Then
With oUF.Designer.Controls.Add("Forms.Label.1")
.Name = "Label1"
.Caption = MsgTxt
.Left = ciBtnLinks
.Top = yPosInUF
.Width = iUFBreite - 20
.Height = 10
.TextAlign = 2 'fmTextAlignCenter
.Font.Bold = True
yPosInUF = yPosInUF + .Height + 5
End With
Else
bFrame = False
End If
' Optional einen Frame für die Controls anlegen
If bFrame = True Then
Set oFrm = oUF.Designer.Controls.Add("Forms.Frame.1")
With oFrm
.Name = "Frame1"
.Left = ciBtnLinks
.Top = yPosInUF
.Width = iUFBreite - 20
End With
iCtrPos = 5 ' Beginnposition Controls
Else
Set oFrm = oUF.Designer ' Keinen Frame anlegen
iCtrPos = yPosInUF ' Beginnposition Controls
End If
' Mehrere gleichartige Controls anlegen
sCtrlTyp = IIf(MultiSel, "CheckBox", "OptionButton")
For iNr = 1 To iAnz
With oFrm.Controls.Add("Forms." & sCtrlTyp & ".1", sCtrlTyp & iNr, True)
.Name = sCtrlTyp & iNr
.Caption = Items(iNr)
.Left = ciBtnLinks
.Top = iCtrPos
.Width = iUFBreite - 20
.Height = 15
iCtrPos = iCtrPos + .Height + 5
' Code dazu
sCode = sCode _
& "Private Sub " & .Name & "_Click()¶" _
& " ControlClick " & .Name & ", " & iNr & "¶" _
& "End Sub¶¶"
End With
Next iNr
' Sammel-Sub Code für die Controls schreiben
sCode = sCode & "Private Sub ControlClick(oCtrl as Object, iNr as Integer)¶"
If MultiSel Then
sCode = sCode & " gvErg(iNr) = IIf(oCtrl.Value = True, oCtrl.Caption, '')¶""
Else
sCode = sCode _
& " gvErg(1) = oCtrl.Caption¶" _
& " Unload Me¶"
End If
sCode = sCode & "End Sub¶¶"
If bFrame Then oFrm.Height = iCtrPos ' Framehöhe anpassen an Controlanzahl
yPosInUF = yPosInUF + (iAnz * 20) + IIf(bFrame, 10, 5) ' Position für die Buttons festlegen
If NoButtons = True Then GoTo SetzeCode ' Es werden keine Buttons gewünscht, damit UF klein bleibt
' Abbrechen-Button erstellen
With oUF.Designer.Controls.Add("Forms.CommandButton.1")
.Name = "Abbrechen"
.Caption = "Abbrechen"
.Left = IIf(MultiSel, ciBtnLinks + ciBtnBreit + ciBtnAbst, iUFBreite \ 2 - ciBtnBreit \ 2 - 4)
.Top = yPosInUF
.Width = ciBtnBreit
.Height = 25
.BackColor = RGB(255, 200, 200)
' Code dazu
sCode = sCode _
& "Private Sub " & .Name & "_Click()¶" _
& " gvErg(1)=vbNullString¶" _
& " Unload Me¶" _
& "End Sub¶¶"
End With
If MultiSel Then
sCode = "Dim bAll as Boolean¶¶" & sCode
' Übernahme-Button erstellen
With oUF.Designer.Controls.Add("Forms.CommandButton.1")
.Name = "Uebernehmen"
.Caption = "Übernehmen"
.Left = ciBtnLinks
.Top = yPosInUF
.Width = ciBtnBreit
.Height = 25
.BackColor = RGB(100, 255, 100)
' Code dazu
sCode = sCode _
& "Private Sub " & .Name & "_Click()¶" _
& " Dim i As Long, Werte As String¶¶" _
& " For i = 1 To UBound(gvErg)¶" _
& " If gvErg(i) <> vbNullString Then Werte = Werte & gvErg(i) & ','¶" _"
& " Next i¶" _
& " If Werte = vbNullString Then¶" _
& " With Label1¶" _
& " .Caption = 'Keine Auswahl getroffen'¶" _"
& " .TextAlign = fmTextAlignCenter¶" _
& " .BackColor = RGB(255,255,100)¶" _
& " .Font.Bold = True¶" _
& " End With¶" _
& " Else¶" _
& " gvErg(1) = Left(Werte, Len(Werte) - 1)¶¶" _
& " Unload Me¶" _
& " End If¶" _
& "End Sub¶¶"
End With
' SetzeAlle-Button erstellen
With oUF.Designer.Controls.Add("Forms.CommandButton.1")
.Name = "ButtonAlle"
.Caption = "Alle auswählen"
.Left = ciBtnLinks
.Top = yPosInUF + 35
.Width = ciBtnBreit
.Height = 25
.BackColor = RGB(255, 255, 100)
' Code dazu
sCode = sCode _
& "Private Sub " & .Name & "_Click()¶" _
& " Dim i As Long, iChk As Long¶¶" _
& " bAll = Not bAll¶" _
& " iChk = bAll And 1¶" _
& " For i = 1 To UBound(gvErg)¶" _
& " gvErg(i) = Controls('" & sCtrlTyp & "' & i).Caption¶" _
& " Controls('" & sCtrlTyp & "' & i).Value = iChk¶" _
& " Next i¶" _
& "End Sub¶¶"
End With
yPosInUF = yPosInUF + 40
End If
yPosInUF = yPosInUF + 40
SetzeCode:
' Erstellten Code ins Modul einfügen
oUF.CodeModule.InsertLines 1, Replace(Replace(sCode, "'", Chr(34)), "¶", vbLf)
oUF.Properties("Height") = yPosInUF + 25
' Userform positionieren
If xPos < 0 And yPos < 0 Then
GetCursorPos PT ' Mausposition holen
xPos = PT.x / 1.67: yPos = PT.y / 1.67
End If
If xPos > 0 And yPos > 0 Then
oUF.Properties("Left") = xPos
oUF.Properties("Top") = yPos
End If
' Userform anzeigen
Set oUF = CallByName(UserForms, "Add", VbMethod, oUF.Name)
sUFName = oUF.Name
oUF.Show
GetAuswahl = Replace(gvErg(1), ",", csSep) ' Auswahl zurückgeben
' Exit Function ' Aktivieren, wenn Userform erhalten bleiben soll
' Userform entfernen
With ActiveWorkbook.VBProject
For Each oUF In .VBComponents
If oUF.Type = 3 And oUF.Name Like sUFName Then
.VBComponents.Remove oUF
End If
Next oUF
End With
End Function
_________
viele Grüße
Karl-Heinz
viele Grüße
Karl-Heinz