ich habe mir eine xla-Datei gebastelt. Wenn ich die Codes in meine Personl.xls einbaue, so funktioniert es prima. Binde ich aber die xla ein, so funtktioniert es nur wenn ich Excel "leer" starte, also mit der von Excel erstellten leeren Mappe "Mappe1".
Aber starte ich eine xls-Datei per Doppelklick, wodurch dann Excel mit dieser Datei gestartet wird, so steht der Debugger in der Zeile:
Set Bereich = Intersect(ActiveWindow.VisibleRange, Rows(Zelle.Row))
der Prozedur "Faerben2()" und meldet "Fehler beim Laden von Diese Arbeitsmappe", drücke ich das weg kommt der gleiche Fehler für "Tabelle1" usw, also für alle Module der zu öffnenden Datei, danach wird Excel geschlossen, also es kommt die Meldung "Excel muß geschlossen werden usw".
Was muß ich tun um diesen Fehler wegzukriegen?
Hier die Datei: https://www.herber.de/bbs/user/54644.xla
Nachstehend ist der Code.
Danke ^ Gruß
Reinhard
In diese Arbeitsmappe
Option Explicit
Dim AppClass As New clsApp
Private Sub Workbook_Open()
Call Loesch
FadenkreuzEinAus = True
Set AppClass.App = Application
End Sub
In Modul1
Option Explicit
Public Fadenkreuzmerker As Range, FadenkreuzEinAus As Boolean
Sub Faerben2(Zelle As Range)
Dim Bereich As Range, Z As Range, N As Integer, D As Variant
Dim Senkrecht
Application.ScreenUpdating = False
Set Bereich = Intersect(ActiveWindow.VisibleRange, Rows(Zelle.Row))
Set Bereich = Union(Bereich, Intersect(ActiveWindow.VisibleRange, Columns(Zelle.Column)))
Set Fadenkreuzmerker = Bereich
On Error Resume Next
D = ActiveSheet.Shapes("Rechteck1").Name
If Err.Number = 0 Then
For Each Z In Bereich
N = N + 1
With ActiveSheet.Shapes("Rechteck" & N)
.Top = Z.Top
.Left = Z.Left
.Height = Z.Height
.Width = Z.Width
End With
Next Z
Else
Err.Clear
For Each Z In Bereich
N = N + 1
ActiveSheet.Shapes.AddShape(msoShapeRectangle, Z.Left, Z.Top, Z.Width, Z.Height).Name = " _
Rechteck" & N
With ActiveSheet.Shapes("Rechteck" & N)
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.SchemeColor = 13
.Fill.Transparency = 0.8
.Line.Visible = msoFalse
.OnAction = "Markieren"
End With
Next Z
End If
Zelle.Select
Ende:
Application.ScreenUpdating = True
End Sub
Sub Loesch()
Dim S
On Error Resume Next
For Each S In ActiveSheet.Shapes
If S.Name Like "Recht*" Then S.Delete
Next S
End Sub
Sub Markieren()
ActiveSheet.Shapes(Application.Caller).TopLeftCell.Select
End Sub
Sub EinAus()
FadenkreuzEinAus = Not FadenkreuzEinAus
If FadenkreuzEinAus = False Then
Call Loesch
Else
If Application.CutCopyMode = 0 Then Call Faerben2(ActiveCell)
End If
End Sub
in Klassenmodul clsApp
Option Explicit
Public WithEvents App As Application
'
Private Sub App_SheetActivate(ByVal Sh As Object)
If FadenkreuzEinAus = False Then Exit Sub
If Application.CutCopyMode = 0 Then Call Faerben2(ActiveCell)
End Sub
'
Private Sub App_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If FadenkreuzEinAus = False Then Exit Sub
If Application.CutCopyMode 0 Then
Call Loesch
Call Faerben2(Target)
End If
End Sub
'
Private Sub App_SheetDeactivate(ByVal Sh As Object)
If FadenkreuzEinAus = False Then Exit Sub
If Not Fadenkreuzmerker Is Nothing Then Call Loesch
End Sub
'
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If FadenkreuzEinAus = False Then Exit Sub
'If Application.CutCopyMode = 0 Then Call Faerben2(Target)
Call Faerben2(Target)
End Sub
'
Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
If FadenkreuzEinAus = False Then Exit Sub
If Not Fadenkreuzmerker Is Nothing Then Call Loesch
End Sub
'
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
If FadenkreuzEinAus = False Then Exit Sub
If Application.CutCopyMode = 0 Then Call Faerben2(ActiveCell)
End Sub
PS: K.A. warum der Parser von Hans mir da Leerzeilen reinbackt