shapes eines Bereiches gruppieren

Sub GruppierungBereich() Dim objShp As Shape Dim rng As Range On Error GoTo Infotext Set rng = Selection For Each objShp In ActiveSheet.Shapes If objShp.Visible = False Then GoTo überspr If Not Intersect(objShp.TopLeftCell, rng) Is Nothing Then objShp.Group überspr: Next Set rng = Nothing GoTo Ende Infotext: MsgBox ("Es wurde kein Bereich selektiert!") Ende: End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
vielleicht könnte so etwas funktionieren;
Du müsstest hinterher ggF. die Shapes wieder ungruppieren
und es müssen mindestens 2 Shapes im Selektionsbereich liegen:

' **********************************************************************
' Modul: Tabelle1 Typ: Klassenmodul Tabellenblatt
' **********************************************************************

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If IsArray(Target) Then Call prcGroupShapes
End Sub



VBA/HTML - CodeConverter für Office-Foren

AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel


Code erstellt und getestet in Office 12

' **********************************************************************
' Modul: Modul1 Typ: Standardmodul
' **********************************************************************

Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long
    
Public Sub prcGroupShapes()
 Dim objShape As Shape
 Dim objCell As Range
 Dim avntShpNames() As Variant
 Dim ialngIndex As Long
   For Each objShape In ActiveSheet.Shapes
      With objShape
          If .Visible Then
             For Each objCell In Selection
                If Not Intersect(.TopLeftCell, objCell) Is Nothing Then
                  ialngIndex = ialngIndex + 1
                  Redim Preserve avntShpNames(ialngIndex - 1) As Variant
                  avntShpNames(ialngIndex - 1) = .Name
                  Exit For
                End If
             Next
          End If
     End With
   Next
   If Not CBool(SafeArrayGetDim(avntShpNames)) Then
     MsgBox "Es wurden keine Shapes selektiert.", vbExclamation
     Exit Sub
   ElseIf Ubound(avntShpNames) < 1 Then
     MsgBox "Mindestens 2 Shapes müssen im Selektionsbereich liegen", vbExclamation
     Exit Sub
   End If
   ActiveSheet.Shapes.Range(avntShpNames).Group
End Sub



VBA/HTML - CodeConverter für Office-Foren

AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel


Code erstellt und getestet in Office 12

Gruß,

Sub ShapesGruppieren() Dim shaShape As Shape Dim lngShape As Long ReDim arrShapes(0) For Each shaShape In ActiveSheet.Shapes If shaShape.Top > Selection.Top And shaShape.Left > Selection.Left And _ (shaShape.Top + shaShape.Height 0 Then ActiveSheet.Shapes.Range(arrShapes()).Group End Sub

Beliebteste Forumthreads (12 Monate)

shapes eines Bereiches gruppieren

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread