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