AW: Shapes mit Text suchen und ausschneiden
27.02.2012 23:17:15
dan
Hallo Peter,
hier eine Meoglichkeit: die sheets und Shapes in for-each durchgehen and wenn der Text im Shape vorhanden ist, dann in ein Array ablegen. Dan ShapeRange bilden und Delete auf dem ShapeRange rufen.
Heir habe ich eine Funktion vom 'Pearson Software Consulting Services' benutzt. Mfg. dan, cz.
Option Explicit
Option Base 0
Private Const boxTitle As String = "Delete shapes"
Public Sub DeleteShapesByText()
On Error GoTo errDeleteShapes
Dim searchedText As String
searchedText = VBA.InputBox("Enter searched text:", boxTitle)
If (searchedText = "") Then
MsgBox "No shapes deleted", vbInformation, boxTitle
Exit Sub
End If
Dim oneSheet As Worksheet
Dim oneShape As Shape
Dim deleteCount As Integer
Dim deleteShapes() As Variant
Dim deleteShapesRange As ShapeRange
Dim i As Integer
For Each oneSheet In Worksheets
Erase deleteShapes
For Each oneShape In oneSheet.shapes
If (VBA.Strings.InStr(oneShape.TextEffect.Text, searchedText) > 0) Then
ReDim Preserve deleteShapes(i)
deleteShapes(i) = oneShape.Name
i = i + 1
End If
Next oneShape
If (IsArrayAllocated(deleteShapes)) Then
Set deleteShapesRange = oneSheet.shapes.Range(deleteShapes)
deleteCount = deleteCount + deleteShapesRange.Count
deleteShapesRange.Delete
End If
Next oneSheet
MsgBox "Deleted shapes count: " & deleteCount, vbInformation, boxTitle
Exit Sub
errDeleteShapes:
MsgBox "Error in 'DeleteShapes': " & Err.Description & " [" & Err.Number & "]", vbCritical, _
boxTitle
End Sub
'
' http://www.cpearson.com/excel/vbaarrays.htm
'
Public Function IsArrayAllocated(Arr As Variant) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _
' IsArrayAllocated
' Returns TRUE if the array is allocated (either a static array or a dynamic array that has _
been
' sized with Redim) or FALSE if the array is not allocated (a dynamic that has not yet
' been sized with Redim, or a dynamic array that has been Erased). Static arrays are always
' allocated.
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
' This function is just the reverse of IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _
Dim N As Long
On Error Resume Next
' if Arr is not an array, return FALSE and get out.
If IsArray(Arr) = False Then
IsArrayAllocated = False
Exit Function
End If
' Attempt to get the UBound of the array. If the array has not been allocated,
' an error will occur. Test Err.Number to see if an error occurred.
N = UBound(Arr, 1)
If (Err.Number = 0) Then
' Under some circumstances, if an array
' is not allocated, Err.Number will be
' 0. To acccomodate this case, we test
' whether LBound