probiere mal diesen Code. Quell- bzw Ziel-Datei werden per Dialog ausgewählt. Die Tabellennamen und Bereiche werden im Code angegeben.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename _
As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
lngFlags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Const OFN_FILEMUSTEXIST As Long = &H1000&
Public Const OFN_HIDEREADONLY As Long = &H4&
Public Const OFN_PATHMUSTEXIST As Long = &H800&
Sub copyRangeMulti()
Dim objWB As Workbook, objWbS As Workbook, objWbT As Workbook
Dim vntRange As Variant
Dim strTab As String, strRef As String
Dim strFilter As String, strFileS As String, strFileT As String
Dim lngFlags As Long, lngIndex As Long
Dim blnOpenS As Boolean, blnOpenT As Boolean
'Tabelennamen und Bereich angeben
' ! = Trenner zwischen Tabellenname und Bereich,
' ; = Trenner zwischen den einzelnen Angaben
Const cstrRange As String = "Tabelle1!A1:D5;Tabelle3!G1:H15"
On Error GoTo ErrExit
tranquilize
lngFlags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST
strFilter = "Alle Dateien (*.*)" & Chr$(0) & "*.*" & Chr$(0) & _
"Excel Dateien (*.xls, *.xlsx, *.xlsm)" & Chr$(0) & "*.xls; *.xlsx; *.xlsm" & Chr$(0)
strFilter = strFilter & Chr$(0)
strFileS = ShowOpen("E:", strFilter, lngFlags, Application.hWnd, 2&, "Quelldatei Auswählen")
If strFileS <> "" Then
strFileT = ShowOpen("E:", strFilter, lngFlags, Application.hWnd, 2&, "Zieldatei Auswählen")
If strFileT <> "" Then
For Each objWB In Application.Workbooks
If objWB.FullName = strFileS Then Set objWbS = objWB
If objWB.FullName = strFileT Then Set objWbT = objWB
Next
If objWbS Is Nothing Then
Set objWbS = Workbooks.Open(strFileS)
blnOpenS = True
End If
If objWbT Is Nothing Then
Set objWbT = Workbooks.Open(strFileT)
blnOpenT = True
End If
vntRange = Split(cstrRange, ";")
For lngIndex = 0 To UBound(vntRange)
strTab = Split(vntRange(lngIndex), "!")(0)
strRef = Split(vntRange(lngIndex), "!")(1)
If SheetExist(strTab, objWbS) And SheetExist(strTab, objWbT) Then
objWbS.Sheets(strTab).Range(strRef).Copy objWbT.Sheets(strTab).Range(strRef)
End If
Next
If blnOpenS Then
objWbS.Close True
Else
objWbS.Save
End If
If blnOpenT Then
objWbT.Close True
Else
objWbT.Save
End If
End If
End If
ErrExit:
tranquilize True
Set objWB = Nothing
Set objWbS = Nothing
Set objWbT = Nothing
End Sub
Private Function ShowOpen(strPath As String, strFilter As String, lngFlags As Long, hWnd As Long, _
Optional lngFIndex As Long = 1&, Optional strTitle As String = "Datei Auswählen") As String
Dim Buffer As String
Dim Result As Long
Dim ComDlgOpenFileName As OPENFILENAME
Buffer = String$(128, 0)
With ComDlgOpenFileName
.lStructSize = Len(ComDlgOpenFileName)
.hwndOwner = hWnd
.lngFlags = lngFlags
.nFilterIndex = lngFIndex
.nMaxFile = Len(Buffer)
.lpstrFile = Buffer
.lpstrFilter = strFilter
.lpstrInitialDir = strPath
.lpstrTitle = strTitle
End With
Result = GetOpenFileName(ComDlgOpenFileName)
If Result <> 0 Then
ShowOpen = Left$(ComDlgOpenFileName.lpstrFile, InStr(ComDlgOpenFileName.lpstrFile, Chr$(0)) - 1)
End If
End Function
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
Public 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