Laufzeitfehler 1004'
04.05.2017 16:18:08
Marc
ich erhalte den Fehler: Die Methode 'Range' für das Objekt '_Worksheet' ist fehlgeschlagen.
Zum Programm: Dadurch, dass sich im Laufe der Zeit viele Versionen einer Excel-Datei mit Vba angesammelt haben, wobei es sowohl Änderungen in einem Tabellenblatt als auch im Code gegeben hat, möchte ich durch Umsetzen der alten in die neuen alle auf den neuesten Stand bringen.
Ich öffne daher die zu bearbeitende Datei (wbQelle) und die Vorlage (wbZiel), kopiere die Werte und führe in der Vorlage eine Sub aus.
Manuell, also wenn ich im VBA-Editor Linie pro Linie abspiele (F8), funktioniert alles bestens.
Sobald ich das Programm normal starte (oder mit F5 im Editor) kommt die Fehlermeldung.
Im Debugger platziert er sich dann auf Zeile:
Set wbZiel = Workbooks.Open(MaskeNeu.Cells(5, 6) & Application.PathSeparator & MaskeNeu.Cells(2, 6))
Allerdings wurde die Vorlage da aber bereits geöffnet!
Ich kann anschließend auch nicht via F8 weiter ausführen, außer ich packe die Vorlagendatei in den Vordergrund ...
Hat jemand eine Idee, woran das liegen könnte?
Arbeitsdateien kann ich nicht bieten, da sind zu viele Daten drin.
Hier der Code:
Private Sub Workbook_Open()
Dim strSep As String
strSep = Application.PathSeparator
Dim objFS As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim j As Integer
With MaskeNeu
.Columns(1).ClearContents
.Columns(2).ClearContents
.Range("A1").Value = "Dateiname"
.Range("B1").Value = "Neue Version Maske"
.Range("F3").Value = ThisWorkbook.Path
.Range("F4").Value = ThisWorkbook.Name
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(Range("F3"))
i = 2
For Each objFile In objFolder.Files
If objFile.Name Like "*.xlsm" And Not objFile.Name = .Range("F4") _
And Not Left(objFile.Name, 1) = "~" Then
.Range("A" & i) = objFile.Name
i = i + 1
End If
Next
If i = 2 Then: MsgBox "Keine Eingabemasken im Ordner": Exit Sub
If MsgBox("Umbenennung jetzt beginnen?", vbYesNo + _
vbDefaultButton2, Range("F4")) = vbNo Then: Exit Sub
Application.ScreenUpdating = False
i = i - 1
For j = 2 To i
If InhalteKopieren(j) Then
.Cells(j, 2) = "OK"
Else
.Cells(j, 2) = "Geht nicht"
End If
Next j
Application.ScreenUpdating = True
End With
End Sub
Function InhalteKopieren(ByVal Reihe As Integer) As Boolean
Dim Test As String
Dim wbQuelle As Workbook
Dim wbZiel As Workbook
Dim shQuelle As Worksheet
Dim shZiel As Worksheet
Dim StrSpeicherName As String
Dim StrAltPfadName As String
Dim StrNeuPfadName As String
InhalteKopieren = True
Set wbQuelle = Workbooks.Open(MaskeNeu.Cells(3, 6) & _
Application.PathSeparator & MaskeNeu.Cells(Reihe, 1))
Set shQuelle = wbQuelle.Sheets("Vertragsmatrix")
StrAltPfadName = wbQuelle.Path & Application.PathSeparator & _
wbQuelle.Name
Set wbZiel = Workbooks.Open(MaskeNeu.Cells(5, 6) & _
Application.PathSeparator & MaskeNeu.Cells(2, 6))
Set shZiel = wbZiel.Sheets("Vertragsmatrix")
With shZiel
.Range("B7") = shQuelle.Range("B7")
.Range("D7") = shQuelle.Range("D7")
.Range("G7") = shQuelle.Range("G7")
.Range("I7") = shQuelle.Range("I7")
.Range("K7") = shQuelle.Range("K7")
.Range("M7") = shQuelle.Range("M7")
.Range("P7") = shQuelle.Range("P7")
.Range("R7") = shQuelle.Range("R7")
.Range("T7") = shQuelle.Range("T7")
.Range("V7") = shQuelle.Range("V7")
.Range("X7") = shQuelle.Range("X7")
.Range("AA7") = shQuelle.Range("AA7")
.Range("AC7") = shQuelle.Range("AC7")
.Range("AE7") = shQuelle.Range("AE7")
.Range("D11") = shQuelle.Range("D11")
.Range("K11") = shQuelle.Range("K11")
.Range("M11") = shQuelle.Range("M11")
.Range("AA11") = shQuelle.Range("AA11")
.Range("AC11") = shQuelle.Range("AC11")
.Range("AE11") = shQuelle.Range("AE11")
.Range("D15") = shQuelle.Range("D15")
.Range("G15") = shQuelle.Range("G15")
.Range("P15") = shQuelle.Range("P15")
.Range("T15") = shQuelle.Range("T15")
.Range("V15") = shQuelle.Range("V15")
.Range("AC15") = shQuelle.Range("AC15")
.Range("AE15") = shQuelle.Range("AE15")
.Range("B21") = shQuelle.Range("B21")
If .Range("B21") = "Neuer Vertrag" Then
.Range("D27") = shQuelle.Range("D27")
.Range("I27") = shQuelle.Range("I27")
If Not .Range("K27").HasFormula Then
.Range("K27") = shQuelle.Range("K27")
End If
Else
.Range("D33") = shQuelle.Range("D33")
.Range("I33") = shQuelle.Range("I33")
.Range("P33") = shQuelle.Range("P33")
.Range("T33") = shQuelle.Range("T33")
.Range("V33") = shQuelle.Range("V33")
.Range("D38") = shQuelle.Range("D38")
.Range("I38") = shQuelle.Range("I38")
If Not .Range("K38").HasFormula Then
.Range("K38") = shQuelle.Range("K38")
End If
End If
End With
wbQuelle.Close SaveChanges:=False
Application.Run "'" & wbZiel.Name & "'!SpeichernNormal", False
StrNeuPfadName = wbZiel.Path & Application.PathSeparator & _
wbZiel.Name
wbZiel.Close SaveChanges:=False
Set wbQuelle = Nothing
Set wbZiel = Nothing
Kill StrAltPfadName
Name StrNeuPfadName As StrAltPfadName
End Function