'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ ein paar Funktionen, die dazu verwendet werden können
'+ NICHT ZUSAMMENHÄNGENDE BEREICHE eines Arbeitsblattes
'+ zu kopieren und an anderer Stelle wieder einzufügen!
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ globale Variable
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private s As Range
Private sh As Worksheet
Private tempsh As Worksheet

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ kopiert (merkt) sich die aktuelle Zellauswahl
'+ diese Funktion kann Probleme bereiten, wenn sich
'+ der copy und der paste Zellbereich überschneiden!
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub copy_areas_local()
Set s = Selection
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ kopiert (merkt) sich die aktuelle Zellauswahl
'+ durch Nutzung eines zusätzlichen temporären Arbeitsblattes
'+ tritt hier das Überschneidungsproblem der obigen Funktion
'+ nicht mehr auf!
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Sub copy_areas()
On Error GoTo err_copy_areas
Set s = Selection
r = s.Areas(1).Cells(1).Row
c = s.Areas(1).Cells(1).Column
Set sh = ActiveSheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
tempsh.Delete
Application.DisplayAlerts = True
On Error GoTo err_copy_areas
ActiveWorkbook.Sheets.Add , Sheets(Sheets.Count)
Set tempsh = ActiveSheet
paste_fkt (Cells(r, c).Address)
Set s = Selection
ActiveSheet.Visible = False
sh.Select
Application.ScreenUpdating = True
Exit Sub
err_copy_areas:
MsgBox "Fehler!"
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ fügt den mittels copy... ermittelten Range ab der
'+ aktiven Zelle wieder ein --- die aktive Zelle
'+ entspricht dabei der Position der ersten Zelle
'+ aus der ersten selektierten Area des mit copy...
'+ kopierten zellbereiches
'+ Bsp copy = "D9:E10";"A1:A3"
'+ aktive Zelle danach auf D11
'+ dann wird mit paste in "D11:E12";"A3:A5" eingefügt
'+ steht die aktive Zelle weiter LINKS, ist das Einfügen
'+ nicht möglich, da "A1:A3" nicht nach Links verschoben
'+ werden kann
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub paste_areas()
   paste_fkt (ActiveCell.Address)
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ interne Funktion
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Sub paste_fkt(Optional ta As String)
On Error GoTo err_paste_fkt
Dim a As Range
Dim h As Range
Dim z As Range
Dim t As Range
Dim r As Long
Dim c As Long

If IsMissing(ta) Then ta = ActiveCell.Address
Set t = Range(ta)
r = t.Row - s.Areas(1).Cells(1).Row
c = t.Column - s.Areas(1).Cells(1).Column
Set z = Nothing

For Each a In s.Areas
   a.Copy
   Set h = ActiveSheet.Range(Range(a.Cells(1).Offset(r, c).Address), _
                Range(a.Cells(1).Offset(r + a.Rows.Count - 1, c + a.Columns.Count - 1).Address))
   h.PasteSpecial
   If z Is Nothing Then
       Set z = h
       Else
       Set z = Union(z, h)
       End If
   Next
z.Select
Exit Sub
err_paste_fkt:
MsgBox "Fehler aufgetreten!"
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ löscht das temporäre Arbeitsblatt
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub delete_area_clipboard()
On Error GoTo err_delete_area_clipboard
Application.DisplayAlerts = False
tempsh.Delete
err_delete_area_clipboard:
Application.DisplayAlerts = True
End Sub