mit VBA Module Programmieren
Oliver
ich möchte mittels AddIn die Ereignisse Workbook_Activate und WorkSheet_Activate programmieren.
Jedes einzeln funktioniert bestens; nur kann ich nicht beide zusammen programmieren lassen.
mein ADD-In hat folgenenden Code
Application.EnableEvents = False
MacWorkbookAktivateEreigniszufügen
MacWorksheetActivateEreigniszufügen
Application.FileDialog(msoFileDialogSaveAs).Execute
Application.EnableEvents = True
die beiden Module sind für einen Schreibschutz in der PHARMA GLP Umgebung
Sub MacWorkbookAktivateEreigniszufügen()
'Fügt in DieseArbeitsmappe des Workbooks ein Macro in Workbook_Activate_Ereignis
Dim x As Variant, x1 As Long, x2 As Long, Anzahl_der_Zeilen As Long, Macrotext As String, _
_
_
Macrotext2 As String
Dim Macrotext3 As String, Macrotext4 As String, Macrotext5 As String, Macrotext6 As String, _
_
_
Macrotext7 As String, Macrotext8 As String, Macrotext9 As String
Macrotext = " If ActiveSheet.Name " & Chr$(34) & "Arbeitsunterlagen" & Chr$(34) & " _
_
_
Then"
Macrotext2 = " Range(Range(" & Chr$(34) & "A1" & Chr$(34) & "), Range(" & Chr$(34) & "E" _
_
_
& Chr$(34) & "& Ende_der_Befund_Tabelle)).Select"
Macrotext3 = " UserName = LCase(Environ(" & Chr$(34) & "USERNAME" & Chr$(34) & "))"
Macrotext4 = " Range(" & Chr$(34) & "A1" & Chr$(34) & ").Select"
Macrotext5 = " Case " & Chr$(34) & "oliver.breith" & Chr$(34) & ", " & Chr$(34) & "julia. _
_
_
brunner" & Chr$(34) & ", " & Chr$(34) & "renate.ruetsch" & Chr$(34) & ", " & Chr$(34) & "sonja. _
_
throm" & Chr$(34) & ", " & Chr$(34) & "angelika.hofer" & Chr$(34) & ", " & Chr$(34) & "felix. _
heppeler" & Chr$(34) & ", " & Chr$(34) & "axel.heppeler" & Chr$(34) & ""
Macrotext6 = " Range(Range(" & Chr$(34) & "A1" & Chr$(34) & "), Range(" & Chr$(34) & " _
D150" & Chr$(34) & ").End(xlUp)).ColorIndex = xlColorIndexAutomatic"
Macrotext7 = " Range(" & Chr$(34) & "A1:G150" & Chr$(34) & ").Select"
Macrotext8 = " If Len(rngAktiveZelle) 0 Or rngAktiveZelle " & Chr$(34) & Chr$(34) & _
_
_
" Then" ' If Len(rngAktiveZelle) = 0 Or rngAktiveZelle = "" Then
Macrotext9 = " Range(" & Chr$(34) & "A65536" & Chr$(34) & ").Select"
With ActiveWorkbook.VBProject.VBComponents("DieseArbeitsmappe").CodeModule
On Error GoTo error_1
x1 = .ProcBodyLine("Workbook_Activate", vbext_pk_Proc)
On Error GoTo 0
Anzahl_der_Zeilen = .CountOfLines
If x1 > 0 Then
x2 = .ProcBodyLine("Workbook_Activate", vbext_pk_Proc)
.DeleteLines 1, Anzahl_der_Zeilen
End If
continue_1:
x1 = .CreateEventProc("Activate", "Workbook")
.InsertLines x1 + 1, "'dieses Activate Makro wurde durch das Add-In per Makro eingefügt" _
_
_
.InsertLines x1 + 2, " Dim rngAktiveZelle As Range, Ende_der_Befund_Tabelle as _
String"
.InsertLines x1 + 3, " Application.ScreenUpdating = False"
.InsertLines x1 + 4, " On Error Resume Next"
.InsertLines x1 + 5, Macrotext 'If ActiveSheet.Name "Arbeitsunterlagen" Then
.InsertLines x1 + 6, " ActiveSheet.Unprotect"
.InsertLines x1 + 7, Macrotext3 'UserName = LCase(Environ("USERNAME"))
.InsertLines x1 + 8, " Select Case UserName"
.InsertLines x1 + 9, Macrotext5 ' Case "julia.brunner", "renate.ruetsch", "sonja. _
throm", "angelika.hofer", "felix.heppeler", "axel.heppeler
.InsertLines x1 + 10, Macrotext7 ' Range("A1:G150").Select
.InsertLines x1 + 11, " Selection.Locked = False"
.InsertLines x1 + 12, " Selection.Font.ColorIndex = xlColorIndexAutomatic"
.InsertLines x1 + 13, Macrotext4 'Range("A1").Select
.InsertLines x1 + 14, " Case Else"
.InsertLines x1 + 15, Macrotext9 ' Range("A65536").Select
.InsertLines x1 + 16, " Ende_der_Befund_Tabelle = ActiveCell.End(xlUp).Row"
.InsertLines x1 + 17, Macrotext2 'Range(Range("A1"), Range("D150").End(xlUp)). _
ColorIndex = xlColorIndexAutomatic
.InsertLines x1 + 18, " For Each rngAktiveZelle In ActiveSheet.UsedRange"
.InsertLines x1 + 19, " rngAktiveZelle.Select"
.InsertLines x1 + 20, Macrotext8 'If Len(rngAktiveZelle) 0 Or rngAktiveZelle "" _
_
_
Then
.InsertLines x1 + 21, " rngAktiveZelle.Select"
.InsertLines x1 + 22, " rngAktiveZelle.Font.ColorIndex = 5"
.InsertLines x1 + 23, " rngAktiveZelle.Locked = True"
.InsertLines x1 + 24, " End If"
.InsertLines x1 + 25, " Next"
.InsertLines x1 + 26, Macrotext4 'Range("A1").Select
.InsertLines x1 + 27, " ActiveSheet.Protect"
.InsertLines x1 + 28, " End Select"
.InsertLines x1 + 29, " End If"
.InsertLines x1 + 30, " Application.ScreenUpdating = True"
End With
Exit Sub
error_1:
On Error GoTo 0
GoTo continue_1
End Sub
Sub MacWorksheetActivateEreigniszufügen()
'Fügt in DieseArbeitsmappe des Workbooks ein Macro in Workbook_SheetActivate_Ereignis
Dim x As Variant, x1 As Long, x2 As Long, Anzahl_der_Zeilen As Long, Macrotext As String, _
Macrotext2 As String
Dim Macrotext3 As String, Macrotext4 As String, Macrotext5 As String, Macrotext6 As String, _
Macrotext7 As String, Macrotext8 As String, Macrotext9 As String
Macrotext = " If ActiveSheet.Name " & Chr$(34) & "Arbeitsunterlagen" & Chr$(34) & " _
Then"
Macrotext2 = " Range(Range(" & Chr$(34) & "A1" & Chr$(34) & "), Range(" & Chr$(34) & "E" _
& Chr$(34) & "& Ende_der_Befund_Tabelle)).Select"
Macrotext3 = " UserName = LCase(Environ(" & Chr$(34) & "USERNAME" & Chr$(34) & "))"
Macrotext4 = " Range(" & Chr$(34) & "A1" & Chr$(34) & ").Select"
Macrotext5 = " Case " & Chr$(34) & "oliver.breith" & Chr$(34) & ", " & Chr$(34) & "julia. _
brunner" & Chr$(34) & ", " & Chr$(34) & "renate.ruetsch" & Chr$(34) & ", " & Chr$(34) & "sonja.throm" & Chr$(34) & ", " & Chr$(34) & "angelika.hofer" & Chr$(34) & ", " & Chr$(34) & "felix.heppeler" & Chr$(34) & ", " & Chr$(34) & "axel.heppeler" & Chr$(34) & ""
Macrotext6 = " Range(Range(" & Chr$(34) & "A1" & Chr$(34) & "), Range(" & Chr$(34) & " _
D150" & Chr$(34) & ").End(xlUp)).ColorIndex = xlColorIndexAutomatic"
Macrotext7 = " Range(" & Chr$(34) & "A1:G150" & Chr$(34) & ").Select"
Macrotext8 = " If Len(rngAktiveZelle) 0 Or rngAktiveZelle " & Chr$(34) & Chr$(34) & _
" Then" ' If Len(rngAktiveZelle) = 0 Or rngAktiveZelle = "" Then
Macrotext9 = " Range(" & Chr$(34) & "A65536" & Chr$(34) & ").Select"
With ActiveWorkbook.VBProject.VBComponents("DieseArbeitsmappe").CodeModule
On Error GoTo error_1
'x1 = .ProcBodyLine("SheetActivate", vbext_pk_Proc)
x1 = .ProcBodyLine("Workbook_SheetActivate", vbext_pk_Proc)
On Error GoTo 0
Anzahl_der_Zeilen = .CountOfLines
If x1 > 0 Then
x2 = .ProcBodyLine("Workbook_SheetActivate", vbext_pk_Proc)
.DeleteLines 1, Anzahl_der_Zeilen
End If
continue_1:
x1 = .CreateEventProc("SheetActivate", "Workbook")
.InsertLines x1 + 1, "'dieses Activate Makro wurde durch das Add-In per Makro eingefügt" _
.InsertLines x1 + 2, " Dim rngAktiveZelle As Range, Ende_der_Befund_Tabelle as _
String"
.InsertLines x1 + 3, " Application.ScreenUpdating = False"
.InsertLines x1 + 4, " On Error Resume Next"
.InsertLines x1 + 5, Macrotext 'If ActiveSheet.Name "Arbeitsunterlagen" Then
.InsertLines x1 + 6, " ActiveSheet.Unprotect"
.InsertLines x1 + 7, Macrotext3 'UserName = LCase(Environ("USERNAME"))
.InsertLines x1 + 8, " Select Case UserName"
.InsertLines x1 + 9, Macrotext5 ' Case "julia.brunner", "renate.ruetsch", "sonja. _
throm", "angelika.hofer", "felix.heppeler", "axel.heppeler
.InsertLines x1 + 10, Macrotext7 ' Range("A1:G150").Select
.InsertLines x1 + 11, " Selection.Locked = False"
.InsertLines x1 + 12, " Selection.Font.ColorIndex = xlColorIndexAutomatic"
.InsertLines x1 + 13, Macrotext4 'Range("A1").Select
.InsertLines x1 + 14, " Case Else"
.InsertLines x1 + 15, Macrotext9 ' Range("A65536").Select
.InsertLines x1 + 16, " Ende_der_Befund_Tabelle = ActiveCell.End(xlUp).Row"
.InsertLines x1 + 17, Macrotext2 'Range(Range("A1"), Range("D150").End(xlUp)). _
ColorIndex = xlColorIndexAutomatic
.InsertLines x1 + 18, " For Each rngAktiveZelle In ActiveSheet.UsedRange"
.InsertLines x1 + 19, " rngAktiveZelle.Select"
.InsertLines x1 + 20, Macrotext8 'If Len(rngAktiveZelle) 0 Or rngAktiveZelle "" _
Then
.InsertLines x1 + 21, " rngAktiveZelle.Select"
.InsertLines x1 + 22, " rngAktiveZelle.Font.ColorIndex = 5"
.InsertLines x1 + 23, " rngAktiveZelle.Locked = True"
.InsertLines x1 + 24, " End If"
.InsertLines x1 + 25, " Next"
.InsertLines x1 + 26, Macrotext4 'Range("A1").Select
.InsertLines x1 + 27, " ActiveSheet.Protect"
.InsertLines x1 + 28, " End Select"
.InsertLines x1 + 29, " End If"
.InsertLines x1 + 30, " Application.ScreenUpdating = True"
End With
Exit Sub
error_1:
On Error GoTo 0
GoTo continue_1
End Sub