Sheetcode in VBA project schreiben

Private Sub Add_code()
Application.ScreenUpdating = False
Application.EnableEvents = True
On Error Resume Next
'clean sheetcode to rebuild macros
For c = 1 To ModCount
cName = "Checkbox" & 1 + ii & "0_Click"
Call DelCodeInTable        'call delete procedure
Next c
'set variables to be used
WBname = ThisWorkbook.Name
n = 1  'to start with checkbox 1(0)
'count number of KPI fields in the worksheet
KPIno = WorksheetFunction.CountIf(Range("B:C"), "Total")
'loop through to write macro code
For d = 1 To KPIno
'check if KPI-field with checkbox existst
nextbox:
If ThisWorkbook.ActiveSheet.OLEObjects("CheckBox" & n & "0").LinkedCell  "" Then
MsgBox "try to write macro  """"CheckBox" & n & "0"""
Call write_Code       'sub-routine to add the macro
n = n + 1                  'increment the counter for the addressing of the checkboxes
Else
MsgBox "Checkbox does not exist."
n = n + 1
If n > 200 Then
GoTo error
Else
GoTo nextbox
End If
End If
Next d
MsgBox "All Macros added"
Application.ScreenUpdating = True
Exit Sub
error:
MsgBox "The remaining macros could not be created." & vbLf & "Please check the Checkbox  _
names and add manually", vbCritical
Exit Sub
End Sub

Und hier der Code fuer das Schreiben der Macros:

Private Sub write_Code()
MsgBox "code for Checkbox" & n & "0 to be inserted"
Dim VBCodeMod As CodeModule
Set VBCodeMod = Workbooks(WBname).VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
With VBCodeMod
.InsertLines 1, "

Private Sub " & "Checkbox" & n & "0_Click()"
.InsertLines 2, "If bActive = True then Exit Sub"
.InsertLines 3, "LCell = ActiveSheet.OLEObjects(""Checkbox" & n & "0""). _
LinkedCell"
.InsertLines 4, "Range(LCell).Select"
.InsertLines 5, "Activecell.Offset(0, -14).Select"
.InsertLines 6, "If ActiveCell.Value = " & """" & "Other reason (Please specify  _
here)" & """" & "Then"
.InsertLines 7, "If Range(LCell).Value = " & """" & "True" & """" & " Then"
.InsertLines 8, "again:"
.InsertLines 9, "   OReason = InputBox(" & """Please describe the other reason(s)  _
for non compliance.""" & "," & """Non-compliance reasons""" & "," _
& """Other reason (Please specify here)""" & ")"
.InsertLines 10, "   If OReason = """" Then"
.InsertLines 11, "again2:"
.InsertLines 12, "tmpstr = MsgBox(" & """No valid entry. Try again?""" & ", _
vbRetryCancel)"
.InsertLines 13, "if not tmpstr = 4 then"
.InsertLines 14, "'Cancel had been selected by user'"
.InsertLines 15, "    bActive = True"
.InsertLines 16, "    Range(lcell).Value = " & """" & "False" & """"
.InsertLines 17, "    OReason = " & """" & "Please describe the other reason(s)  _
for non compliance." & """"
.InsertLines 18, "    bActive = False"
.InsertLines 19, "    Exit Sub"
.InsertLines 20, "   Else"
.InsertLines 21, "    goto again"
.InsertLines 22, "   end if"
.InsertLines 23, "  End If"
.InsertLines 24, "  If Oreason = " & """" & "Other reason (Please specify here)" & _
"""" & " then"
.InsertLines 25, "   goto again2:"
.InsertLines 26, "  end if"
.InsertLines 27, "  ActiveCell.Value = OReason"
.InsertLines 28, "End If"
.InsertLines 29, " Else"
.InsertLines 30, "  ActiveCell.Value = " & """" & "Other reason (Please specify  _
here)" & """"
.InsertLines 31, "End If"
.InsertLines 32, " "
.InsertLines 33, "End Su-b"  'geaendert, zur kompletten Darstellung im Forum
End With
Set VBCodeMod = Nothing
'some code to save the macro?
MsgBox "Macro added: Checkbox" & n & "0"
End Sub


Bin fuer jede Hilfe dankbar!

Gruesse (bei z.Z. 41 Grad)

Dirk aus Dubai