ich habe den Code jetzt auch getestet und er läuft bei mir tadellos.
Ich habe zur Sicherheit noch eine Abfrage eingebaut, ob das Quellblatt vorhanden ist.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub wert_uebertragen()
Dim wb_source As Workbook, wb_target As Workbook, objWB As Workbook
Dim ws_source As Worksheet, ws_target As Worksheet
Const quellpfad = "E:\Temp"
Const zielpfad = "E:\Temp1"
Const name_mappe_quelle = "Datenbasis.xlsm"
Const name_mappe_ziel = "Faktur.xlsx"
Const quellblatt = "Preise"
Const zielblatt = "Auswertung"
Const quellzelle = "B2"
Const zielzelle = "A1"
On Error GoTo ErrExit
tranquilize
For Each objWB In Application.Workbooks
If objWB.Name = name_mappe_quelle Then
Set wb_source = objWB
Exit For
End If
Next
If wb_source Is Nothing Then
If Dir(quellpfad & "\" & name_mappe_quelle, vbNormal) <> "" Then
Set wb_source = Workbooks.Open(quellpfad & "\" & name_mappe_quelle)
Else
MsgBox "Quellmappe kann nicht geöffnet werden"
GoTo ErrExit
End If
End If
If Dir(zielpfad, vbDirectory) = "" Then
MakeSureDirectoryPathExists (zielpfad & IIf(Right(zielpfad, 1) = "\", "", "\"))
Set wb_target = Workbooks.Add
wb_target.Sheets(1).Name = zielblatt
wb_target.SaveAs zielpfad & "\" & name_mappe_ziel, FileFormat:=xlOpenXMLWorkbook
Else
For Each objWB In Application.Workbooks
If objWB.Name = name_mappe_ziel Then
Set wb_target = objWB
Exit For
End If
Next
If wb_target Is Nothing Then
If Dir(zielpfad & "\" & name_mappe_ziel, vbNormal) <> "" Then
Set wb_target = Workbooks.Open(zielpfad & "\" & name_mappe_ziel)
Else
Set wb_target = Workbooks.Add
wb_target.Sheets(1).Name = zielblatt
wb_target.SaveAs zielpfad & "/" & name_mappe_ziel, FileFormat:=xlOpenXMLWorkbook
End If
End If
End If
If SheetExist(quellblatt, wb_source) Then
Set ws_source = wb_source.Worksheets(quellblatt)
Else
MsgBox "Tabelle '" & quellblatt & "' in '" & name_mappe_quelle & "' nicht gefunden!"
GoTo ErrExit
End If
If SheetExist(zielblatt, wb_target) Then
Set ws_target = wb_target.Worksheets(zielblatt)
Else
Set ws_target = wb_target.Sheets.Add
ws_target.Name = zielblatt
End If
ws_source.Range(quellzelle).Copy ws_target.Range(zielzelle)
wb_target.Close True
wb_source.Close False
ErrExit:
tranquilize True
Set wb_source = Nothing
Set wb_target = Nothing
Set ws_source = Nothing
Set ws_target = Nothing
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Private Sub tranquilize(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
If Modus Then
With Err
If .Number <> 0 Then
MsgBox IIf(Erl, vbLf & "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbLf & _
.Description, vbExclamation, "Fehler"
End If
.Clear
End With
End If
End Sub