AW: Bstehender VBA Code
21.08.2016 19:58:30
Luna
Hier der Code
Option Explicit
Public pstrVal As String
Sub sbAddCheckBoxes(myrange As Range)
Dim lchkChkB As Excel.CheckBox, liChkB As Integer, lrgTMP As Range
For liChkB = 1 To 4
Select Case liChkB
Case 1
Set lrgTMP = ActiveSheet.Cells(myrange.Row, 9)
Case 2
Set lrgTMP = ActiveSheet.Cells(myrange.Row, 10)
Case 3
Set lrgTMP = ActiveSheet.Cells(myrange.Row, 11)
Case 4
Set lrgTMP = ActiveSheet.Cells(myrange.Row, 12)
End Select
Set lchkChkB = ActiveSheet.CheckBoxes.Add(lrgTMP.Left + lrgTMP.Width / 2, lrgTMP. _
Top, 1, lrgTMP.Height)
With lchkChkB
.Left = .Left - .Width / 2 + 4
.Characters.Text = ""
.Name = lrgTMP.Row & "_" & liChkB
.OnAction = "sbChkB_Call"
End With
Next
Set lrgTMP = Nothing
Set lchkChkB = Nothing
End Sub
Sub sbChkB_Call()
Dim larstrSplit() As String, liChkB As Integer, larloColor(3) As Long
larloColor(0) = 3
larloColor(1) = 46
larloColor(2) = 6
larloColor(3) = 43
larstrSplit = Split(ActiveSheet.CheckBoxes(Application.Caller).Name, "_")
Range("A" & CInt(larstrSplit(0)) & ":L" & CInt(larstrSplit(0))).Interior.ColorIndex = _
xlNone
For liChkB = 1 To 4
If ActiveSheet.CheckBoxes(larstrSplit(0) & "_" & liChkB).Value = 1 Then
If liChkB
Sub sbChkDel(ByVal zeile As Long)
Dim lshpChk As Shape
For Each lshpChk In ActiveSheet.Shapes
If Left(lshpChk.Name, 2) = zeile & "_" Then
lshpChk.Delete
End If
Next
End Sub
Function fcMultiSel(markierung As String) As Boolean
Dim lstrSplit() As String, lstrDummy As String, lboNotRow As Boolean, liChar As Integer
If InStr(markierung, ":") > 0 Or _
InStr(markierung, ";") > 0 Then
MsgBox "Mehrfachauswahl hier nicht möglich.", vbExclamation
lstrDummy = Replace(markierung, ":", "")
lstrDummy = Replace(lstrDummy, ";", "")
lstrDummy = Replace(lstrDummy, "$", "")
For liChar = 1 To Len(lstrDummy)
If Not IsNumeric(Mid(lstrDummy, liChar, 1)) Then
lboNotRow = True
Exit For
End If
Next
If InStr(markierung, ":") > 0 Then
lstrSplit = Split(markierung, ":")
Else
lstrSplit = Split(markierung, ";")
End If
If lboNotRow = True Then
Range(lstrSplit(0)).Select
Else
Range("$A" & lstrSplit(0)).Select
End If
fcMultiSel = True
End If
End Function