Laufzeitfehler zwar lokalisiert, aber noch unklar
15.08.2009 22:36:59
Jörg-HH
Hallo alle,
mein Problem besteht nach wie vor. Es tritt auf in einer Version, bei der ich Buttons von einem Blatt in ein anderes verlegt habe. Die Prozedur, die von dem Fehler betroffen ist, ist die da unten. Teile davon stammen von Tino. Einen screenshot von der Stelle, wo der Fehler auftritt, habe ich hochgeladen https://www.herber.de/bbs/user/63858.doc
Wär schön, wenn jemand eine Idee hätte, was da schief ist...
Grüße - Jörg
Public Sub ToDo_Formular_versandfertig()
' - überträgt die Einstellungen im Blatt "Formular" auf die folgenden Blätter
' - löscht alle Blätter außer config, ToDo und Formular
' - erstellt Passwortschutz
' - erstellt daraus eine neue Datei, die per Email versendet werden kann
'TEIL 1 - Formularblatt in Blätter für Auftragnehmer kopieren
Dim ws As Worksheet
Dim wsFormular As Worksheet
Dim bHinterFormular As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
bHinterFormular = False
Set wsFormular = ThisWorkbook.Worksheets("Formular")
For Each ws In ThisWorkbook.Worksheets
If ws.Name "config" _
And ws.Name "ToDo" _
And ws.Name "Formular" _
And bHinterFormular = True Then
ws.Cells.Clear 'Inhalt im Blatt "Formular" leeren und markieren
wsFormular.Cells.Copy 'Inhalt im Blatt "Formular" kopieren
ws.Range("A1").PasteSpecial Paste:=xlPasteAll 'Inhalt in aktuelles Blatt der FOR- _
Schleife einfügen
wsFormular.Buttons("btnInfobereichDrucken").Copy 'Druckbutton kopieren
ws.Activate 'im selben Blatt an eine bestimmte Stelle einfügen
ws.Range("BL257").Select
ws.Paste
ws.Range("A1").Select 'aktive Zelle auf A1 stellen
End If
'wenn die FOR-Schleife das Blatt Formular abgearbeitet _
hat,
'dann liegen die "nächsten Blätter" hinter diesem...
If ws.Name = "Formular" Then
bHinterFormular = True
End If
Next ws
Application.CutCopyMode = False 'gestrichelte Linie um kopierte Zellen entfernen
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
wsFormular.Activate 'wieder das Formularblatt aktivieren...
ActiveWorkbook.Save 'Datei sichern. Damit ist die Datei fertiggestellt,
'die später die Rückläufer aufnehmen wird.
MsgBox "Es wird nun für" & ProjName & " " & TPName & vbLf & "das Formular für die _
AUSSCHREIBUNG erstellt." _
& vbLf & "Speichern Sie es im Ordner Ihrer Wahl." & vbLf & "Anschliessend _
kann es versendet werden.", vbOKOnly, "Ausschreibung erstellen"
FileSaveName2 = Application.GetSaveAsFilename(InitialFileName:=ProjName & " Ausschr " & TPName, _
FileFilter:="Microsoft Excel-Arbeitsmappe (*.xls), *.xls", Title:="Datei für Ausschreibungsformular " & ProjName & " " & TPName & " erstellen:")
If FileSaveName2 False Then
ActiveWorkbook.SaveAs FileSaveName2
Else
Exit Sub
End If
'TEIL 2 - nicht benötigte Blätter löschen
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
MsgBox "Die Arbeitsmappe wird jetzt" _
& vbLf & "für die Ausschreibung bereinigt." _
& vbLf & "Dies kann einige Minuten dauern.", vbOKOnly, "Arbeitsblätter löschen"
Dim sAr() As String
Dim i As Integer
Dim mySh As Worksheet
For Each mySh In ThisWorkbook.Worksheets
If mySh.Name "Formular" And mySh.Name "config" And mySh.Name "ToDo" Then
ReDim Preserve sAr(i)
sAr(i) = mySh.Name
i = i + 1
End If
Next mySh
Application.DisplayAlerts = False
Sheets(sAr).Delete
Application.DisplayAlerts = True
'TEIL 3 - Ausblenden im übriggebliebenen Formularblatt, was der User nicht sehen soll
' und löschen, was Palo stört
' Worksheets("Formular").Shapes("cmdDruckFormularBereich").Delete
' Worksheets("Formular").Shapes("cmdFormularSpeichern").Delete
Worksheets("Formular").Shapes("CmBt_FormularFertig").Delete
Worksheets("Formular").Shapes("CmdBt_int_FormularKopieren").Delete
'Dim wsConfig As Worksheet
'Dim wsTarget As Worksheet
Set wsConfig = ThisWorkbook.Worksheets("Config")
'verbirgt alles, was rechts und unterhalb des Formulars ist (z.B. Sprachlisten, Durchlaufü _
bersicht):
With wsFormular
.Range(.Range(wsConfig.Range("B6").Value), .Range(wsConfig.Range("B7").Value)).EntireColumn. _
Hidden = True
.Range(.Range(wsConfig.Range("B8").Value), .Range(wsConfig.Range("B9").Value)).EntireRow. _
Hidden = True
.Range(.Range(wsConfig.Range("AI12").Value), .Range(wsConfig.Range("AI13").Value)).Copy
.Range(.Range(wsConfig.Range("AI12").Value), .Range(wsConfig.Range("AI13").Value)). _
PasteSpecial Paste:=xlPasteValues
End With
Application.EnableEvents = False
Worksheets(Array("config", "ToDo")).Visible = False
Application.EnableEvents = True
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayWorkbookTabs = False
End With
PW = InputBox("Vergeben Sie nun ein Passwort", "Abschluss")
wsFormular.Protect PW
ThisWorkbook.Protect PW
ActiveWorkbook.Save 'Datei sichern (jetzt ist es die Ausschreibung)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox (" Fertig !")
End Sub