Excel: Bereiche kopieren

Sub Kopieren()
Set cpy = Worksheets(eins).Range(A3:CV4)
cpy.Copy Destination:=Worksheets(pivot).Range(A1)
End Sub

Sub Kopieren_VT()
Set cpy = Worksheets(eins).Range(A6:CV10)
cpy.Copy Destination:=Worksheets(pivot).Range(A3)
End Sub

Sub Kopieren()
Set cpy1 = Worksheets(eins).Range(A3:CV4)
cpy1.Copy Destination:=Worksheets(pivot).Range(A1)
Set cpy = Worksheets(eins).Range(A6:CV10)
cpy.Copy Destination:=Worksheets(pivot).Range(A3)
End Sub

Sub BereichKopieren()
 Dim wb_quelle As Workbook, range_ziel As Range, range_quelle As Range
 Dim bSchonOffen As Boolean
 
->>>>>>>>>>>>>> A N P A S S E N >>>>>>>>>>>>>>>>
 Const cWBQUELLE_DATEINAME = Mappe1.xls->Name der Quelldatei
 Const cWBQUELLE_PFAD = F:\Test    ->Pfad der Quelldatei
 Const cWSQUELLE_NAME = eins     ->Name des Quellblattes
 Const cRANGEQUELLE = A3:CV4     ->Bereich auf dem Quellblatt
 
 Const cWSZIEL_NAME = xyz       ->Name des Zielblattes
->>>>>>>>>>>>>> A N P A S S E N  E N D E >>>>>>
 
 On Error Resume Next
 Set range_ziel = ActiveWorkbook.Worksheets(cWSZIEL_NAME).Range(A1)
 On Error GoTo 0
 Err.Clear
 If range_ziel Is Nothing Then
  MsgBox Zielbereich ist nicht erreichbar.
  GoTo AUFRAEUMEN
 End If
 
 For Each wb_quelle In Workbooks
  If wb_quelle.Name = cWBQUELLE_DATEINAME Then
   bSchonOffen = True
   Exit For
  End If
 Next
 If Not bSchonOffen Then
  On Error Resume Next
  Set wb_quelle = Workbooks.Open(Filename:= _
     cWBQUELLE_PFAD & Application.PathSeparator & cWBQUELLE_DATEINAME)
  On Error GoTo 0
  Err.Clear
 End If
 If wb_quelle Is Nothing Then
  MsgBox cWBQUELLE_PFAD & Application.PathSeparator & _
      cWBQUELLE_DATEINAME & konnte nicht geöffnet werden.
  GoTo AUFRAEUMEN
 End If
 
 On Error Resume Next
 Set range_quelle = wb_quelle.Worksheets(cWSQUELLE_NAME).Range(cRANGEQUELLE)
 On Error GoTo 0
 Err.Clear
 If range_quelle Is Nothing Then
  MsgBox Quellbereich ist nicht erreichbar.
  GoTo AUFRAEUMEN
 End If
 
 range_quelle.Copy Destination:=range_ziel

 If Not bSchonOffen Then wb_quelle.Close Savechanges:=False

AUFRAEUMEN:
 Set wb_quelle = Nothing: Set range_ziel = Nothing: Set range_quelle = Nothing
End Sub

Sub MeherereBereicheKopieren()
->>>>>>>>>>>>>> A N P A S S E N >>>>>>>>>>>>>>>>
 Const c1WBQUELLE_DATEINAME = Mappe1.xls->Name der Quelldatei
 Const c1WBQUELLE_PFAD = F:\Test    ->Pfad der Quelldatei
 Const c1WSQUELLE_NAME = eins     ->Name des Quellblattes
 Const c1RANGEQUELLE = A3:CV4     ->Bereich auf dem Quellblatt
 Const c1WSZIEL_NAME = xyz       ->Name des Zielblattes
 Const c1RANGEZIEL = A1        ->Bereich auf dem Quellblatt
 
 Const c2WBQUELLE_DATEINAME = Mappe2.xls->Name der Quelldatei
 Const c2WBQUELLE_PFAD = F:\Test    ->Pfad der Quelldatei
 Const c2WSQUELLE_NAME = eins     ->Name des Quellblattes
 Const c2RANGEQUELLE = A3:CV4     ->Bereich auf dem Quellblatt
 Const c2WSZIEL_NAME = xyz       ->Name des Zielblattes
 Const c2RANGEZIEL = A3        ->Bereich auf dem Quellblatt
->>>>>>>>>>>>>> A N P A S S E N  E N D E >>>>>>

 Dim ws_ziel As Workbook

 Set ws_ziel = ActiveWorkbook

 Call EinenBereichKopieren(c1WBQUELLE_DATEINAME, _
              c1WBQUELLE_PFAD, _
              c1WSQUELLE_NAME, _
              c1RANGEQUELLE, _
              ws_ziel, _
              c1WSZIEL_NAME, _
              c1RANGEZIEL)

 Call EinenBereichKopieren(c2WBQUELLE_DATEINAME, _
              c2WBQUELLE_PFAD, _
              c2WSQUELLE_NAME, _
              c2RANGEQUELLE, _
              ws_ziel, _
              c2WSZIEL_NAME, _
              c2RANGEZIEL)

AUFRAEUMEN:
 Set ws_ziel = Nothing
End Sub

Private Function EinenBereichKopieren(sWBQUELLE_DATEINAME As String, _
                   sWBQUELLE_PFAD As String, _
                   sWSQUELLE_NAME As String, _
                   sRANGEQUELLE As String, _
                   wb_ziel As Workbook, _
                   sWSZIEL_NAME As String, _
                   sRANGEZIEL As String)
 
 Dim wb_quelle As Workbook, range_ziel As Range, range_quelle As Range
 Dim bSchonOffen As Boolean
 Dim sFullName As String
 
 
 On Error Resume Next
 Set range_ziel = wb_ziel.Worksheets(sWSZIEL_NAME).Range(sRANGEZIEL)
 On Error GoTo 0
 Err.Clear
 If range_ziel Is Nothing Then
  MsgBox Zielbereich ist nicht erreichbar. & vbLf & Blatt:  & sWSZIEL_NAME
  GoTo AUFRAEUMEN
 End If
 
 For Each wb_quelle In Workbooks
  If wb_quelle.Name = sWBQUELLE_DATEINAME Then
   bSchonOffen = True
   Exit For
  End If
 Next
 If Not bSchonOffen Then
  On Error Resume Next
  sFullName = sWBQUELLE_PFAD & Application.PathSeparator & sWBQUELLE_DATEINAME
  Set wb_quelle = Workbooks.Open(Filename:=sFullName)
  On Error GoTo 0
  Err.Clear
 End If
 If wb_quelle Is Nothing Then
  MsgBox sFullName &  konnte nicht geöffnet werden.
  GoTo AUFRAEUMEN
 End If
 
 On Error Resume Next
 Set range_quelle = wb_quelle.Worksheets(sWSQUELLE_NAME).Range(sRANGEQUELLE)
 On Error GoTo 0
 Err.Clear
 If range_quelle Is Nothing Then
  MsgBox _
   Quellbereich ist nicht erreichbar. & vbLf & _
   Blatt:  & sWSQUELLE_NAME & vbLf & _
   Bereich:  & sRANGEQUELLE
  GoTo AUFRAEUMEN
 End If
 
 range_quelle.Copy Destination:=range_ziel

 If Not bSchonOffen Then wb_quelle.Close Savechanges:=False

AUFRAEUMEN:
 Set wb_quelle = Nothing: Set range_ziel = Nothing: Set range_quelle = Nothing
End Function