Shapes Gruppieren in bestimmten Bereich (Name gleich)

[Abitus]

Grüß Euch,

bräuchte nochmal eure Hilfe. Ich möchte gerne in einem bestimmten Bereich (wichtig, nicht das ganze Tabellenblatt!) mehrere Shapes Gruppieren. Dabei kann es passieren, das die Shapes den identischen Namen haben.

Habt ihr eine Lösung dafür?

Vielen Dank

Abitus

[Kuwer]

Hallo Abitus,

markiere die Teile bei gedrückter Shifttaste und gruppiere sie anschließend unter Seitenlayout > Gruppieren.

Gruß Uwe

[Abitus]

Servus Uwe,

großer Fehler von mir, das hab ich nicht dazu geschrieben. Ich suche eine VBA Lösung, deshalb auch die Beispielmappe!

Gruß Abitus

[Ego]

Hallo Abitus,

warum ?

Wenn  ich es mit eindeutigen Namen kann, dann mache ich die Namen eindeutig.

[Abitus]

Hallo Helmut,

gibt es eine Möglichkeit, mehrere Shapes mit dem gleichen Namen zu Selektieren?

Gruß Abi

[Ego]

Hallo Abitus,

kenn ich nicht. Warum machst du die Namen nich eindeutig?

[Abitus]

Hallo Helmut,

ich gebe dir natürlich recht, das ist wohl die einfachste Lösung. Nur war das meinem Kollegen nicht ganz so klar.

Gruß Dirk

[Kuwer]

Hallo Dirk,

Du müsstest jetzt nur noch eine konkrete Frage stellen, denn Deine "Beispieldatei" gibt ja nicht viel her.

Gruß Uwe

[Abitus]

Servus Uwe,

ich möchte gerne im Bereich von E12:O47 alles Shapes, die in diesem Bereich sind, per VBA Gruppieren. Dabei ist zu beachten, das die Shapes auch teilweise den gleichen Namen besitzen.

Ist das überhaupt möglich?

Gruß Dirk

[Kuwer]

Hallo Dirk,

teste es mal damit:

Sub GrafikenImBereichGruppieren()
 Dim lngA() As Long
 Dim lngI As Long
 Dim rngB As Range
 ReDim lngA(0 To 0)
 
 With ActiveSheet
   Set rngB = .Range("E12:O47")
   For lngI = 1 To .Shapes.Count
     If .Shapes(lngI).Top >= rngB.Top Then
       If .Shapes(lngI).Left >= rngB.Left Then
         If .Shapes(lngI).Top + .Shapes(lngI).Height <= rngB.Top + rngB.Height Then
           If .Shapes(lngI).Left + .Shapes(lngI).Width <= rngB.Left + rngB.Width Then
             If LBound(lngA) = 0 Then
               ReDim lngA(1 To 1)
             Else
               ReDim Preserve lngA(1 To UBound(lngA) + 1)
             End If
             lngA(UBound(lngA)) = lngI
           End If
         End If
       End If
     End If
   Next lngI
   If UBound(lngA) > 1 Then
     .Shapes.Range(lngA).Group
     MsgBox UBound(lngA) & " Objekte wurden gruppiert."
   Else
     If UBound(lngA) = 1 Then
       MsgBox "Es wurde nur ein Objekt gefunden."
     Else
       MsgBox "Es wurde kein Objekt gefunden."
     End If
   End If
 End With
End Sub

Code eingefügt mit: Excel Code Jeanie

Gruß Uwe