Option Explicit
Sub AddIt(myCell As Range)
If Intersect(Columns("B"), myCell) Is Nothing _
Or myCell.Formula <> "" Then Exit Sub
myCell.Formula = Trim(myCell.Offset(0, -1).Formula) & _
Chr(45) & AddkMyPropertie
End Sub
Sub MkCustomProperties()
Dim oWsh As Worksheet
Dim oCsp As CustomProperty
Set oWsh = ThisWorkbook.ActiveSheet
With oWsh
For Each oCsp In .CustomProperties
If oCsp.Name = "Anforderung" Then
Select Case MsgBox("auf Null setzen ?", _
vbYesNo Or vbExclamation Or vbDefaultButton1, _
"Metadaten vorhanden")
Case vbYes
oCsp.Delete
Case vbNo
Exit Sub
End Select
End If
Next oCsp
.CustomProperties.Add _
Name:="Anforderung", Value:=0
End With
Set oWsh = Nothing
End Sub
Function AddkMyPropertie() As String
Dim oWsh As Worksheet
Dim oCsp As CustomProperty
Set oWsh = ThisWorkbook.ActiveSheet
With oWsh
For Each oCsp In .CustomProperties
If oCsp.Name = "Anforderung" Then
oCsp.Value = oCsp.Value + 1
AddkMyPropertie = Format(oCsp.Value, "0000")
End If
Next oCsp
End With
Set oWsh = Nothing
End Function
Function ChkMyPropertie() As String
Dim oWsh As Worksheet
Dim oCsp As CustomProperty
Set oWsh = ThisWorkbook.ActiveSheet
With oWsh
For Each oCsp In .CustomProperties
If oCsp.Name = "Anforderung" Then _
ChkMyPropertie = Format(oCsp.Value, "0000")
Next oCsp
End With
Set oWsh = Nothing
End Function