AW: Shapes & Bereich löschen & Einfügen
18.03.2008 11:50:08
fcs
Hallo Heinz,
das war jetzt doch etwas komplizierter als erwartet. Hier meine Lösung
Gruß
Franz
Sub aaaTest()
Dim wsVor As Worksheet, wsMatNr As Worksheet, ShapeNamen() As Variant, iI As Long
Dim BereichMat As Range, BereichVor As Range, element As Shape
Set wsVor = Worksheets("Vorschlag")
Set wsMatNr = Worksheets("Material-Nummern")
With wsVor
Set BereichVor = .Range(.Cells(41, 8), .Cells(51, 14)) 'H41:N51
BereichVor.Clear 'Inhalte und Formate im Bereich löschen
'Shapes löschen, die mit Bereich überlappen
For Each element In .Shapes
If Not Intersect(.Range(element.TopLeftCell, element.BottomRightCell), _
BereichVor) Is Nothing Then
element.Delete
End If
Next
End With
With wsMatNr
Set BereichMat = .Range(.Cells(2, 8), .Cells(12, 22)) 'H2:V12
'Shapenamen merken, die mit dem Bereich überlappen
For Each element In .Shapes
If element.Placement = xlFreeFloating Then 'Element ist nicht an Zelle gebunden
If Not Intersect(.Range(element.TopLeftCell, element.BottomRightCell), _
BereichMat) Is Nothing Then
iI = iI + 1
ReDim Preserve ShapeNamen(1 To iI)
ShapeNamen(iI) = element.Name
End If
End If
Next
'Zellen + zellgebundene Shapes kopieren
BereichMat.Copy Destination:=BereichVor.Range("a1")
If iI > 0 Then
'gemerkte Shapes kopieren
For iI = 1 To UBound(ShapeNamen)
LeftDiff = BereichMat.Left - .Shapes(ShapeNamen(iI)).Left
TopDiff = BereichMat.Top - .Shapes(ShapeNamen(iI)).Top
.Shapes(ShapeNamen(iI)).Copy
wsVor.Paste
wsVor.Shapes(wsVor.Shapes.Count).Top = BereichVor.Top - TopDiff
wsVor.Shapes(wsVor.Shapes.Count).Left = BereichVor.Left - LeftDiff
Next
End If
End With
wsVor.Activate
BereichVor.Range("a1").Select
End Sub