Microsoft Excel

Herbers Excel/VBA-Archiv

shapes kopieren

Betrifft: shapes kopieren von: stef26
Geschrieben am: 14.08.2014 08:24:13

Guten Morgen,
ich bräuchte mal eure Hilfe.

Ich habe in meiner Mappe mehrere Shapes.
Der Benutzer selektiert sich ein paar Shapes.

Mit einem Macro sollen alle markierten shapes umbenannt werden. Aktueller Name + (1).
Dann sollen diese zu einer Gruppe gruppiert werden.

Da ich mit meinen VBA Kenntissen hier nicht weiter komme, bräuchte ich hier eure Unterstützung.

Liebe Grüße
Stefan

  

Betrifft: AW: shapes kopieren von: Beverly
Geschrieben am: 14.08.2014 10:22:23

Hi Stefan,

dazu hast du doch bereits vor ein paar Tagen 2 Threads eröffnet - weshalb nun einen weiteren?

Sub ShapesUmbenennen()
   Dim shaShape As Shape
   Dim strName As String
   Dim lngShape As Long
   Dim lngZaehler As Long
   Dim arrShapes()
   ReDim arrShapes(0)
   If TypeName(Selection) = "DrawingObjects" Then
      For Each shaShape In Selection.ShapeRange
         strName = Left(shaShape.Name, InStrRev(shaShape.Name, " ") - 1)
         lngShape = Trim(Application.Substitute(shaShape.Name, strName, ""))
         shaShape.Name = strName & " " & lngShape + 1
         ReDim Preserve arrShapes(0 To lngZaehler)
         arrShapes(lngZaehler) = shaShape.Name
         lngZaehler = lngZaehler + 1
      Next shaShape
   End If
   If arrShapes(0) <> "" Then
      If UBound(arrShapes) > 0 Then
         ActiveSheet.Shapes.Range(arrShapes()).Group
      End If
   End If
End Sub

GrußformelBeverly's Excel - Inn


  

Betrifft: AW: shapes kopieren von: stef26
Geschrieben am: 14.08.2014 18:41:38

super

BESTEN DANK

Liebe Grüße
Stefan


  

Betrifft: AW: shapes kopieren von: stef26
Geschrieben am: 14.08.2014 21:04:26

Hallo,
nachdem ich dein Macro getestet hatte, hab ich es in meiner Anwendung reingemacht.
In der Test hat es ohne Probleme funktioniert.
In meiner Anwendung bleibt das Macro leider stehen ???

Kann es damit zusammenhängen, dass es sich dabei teilweise um Gruppierungen handelt ?
Hab mal ein Beispiel aus meiner Mappe in eine XLS hochgeladen...
https://www.herber.de/bbs/user/92120.xlsm

Gibt es trotzdem vielleicht hier ne Möglichkeit dies zu realisieren ?

Liebe Grüsse
Stefan


  

Betrifft: AW: shapes kopieren von: Beverly
Geschrieben am: 14.08.2014 22:38:27

Hi Stefan,

es liegt nicht an den Gruppierungen. Ich bin davon ausgegangen, dass alle deine Shapes bereits am Ende des Namens eine Nummer haben und diese Nummer durch eine Leerstelle vom Rest des Namen abgetrennt ist. Die Shapes in deiner jetzigen Mappe entsprechen jedoch nicht diesem Schema - einige haben überhaupt keine Zahl am Ende, bei anderen ist die Zahl durch einen : vom restlichen Namen getrennt. Wenn die Benennung deiner Shapes unterschiedliche Konstellationen aufweist, dann ist das auf diesem Weg nicht möglich.
Ich würde dir z.B. empfehlen, zuerst einmal generell allen Shapes am Ende des Namen die Zahl 1 anzuhängen und zwischen den eigentlichen Namen und die Zahl z.B. einen "_" setzen - auf diesen kann man dann Bezug nehmen, um die laufende Nummerierung festzustellen und diese jeweils um 1 zu erhöhen. Den Code müsstest du dann wie folgt ändern:

         strName = Left(shaShape.Name, InStrRev(shaShape.Name, "_") - 1)
         lngShape = Application.Substitute(shaShape.Name, strName & "_", "")
         shaShape.Name = strName & "_" & lngShape + 1

GrußformelBeverly's Excel - Inn


  

Betrifft: AW: shapes kopieren von: stef26
Geschrieben am: 15.08.2014 07:36:53

Hallo Karin, alias Beverly,
vielen Danke für die Hilfe. Ich werde in meiner Mappe die Namensgebung aller Komponenten (Shapes) anpassen, so dass immer _1 dahinter steht. (Wird ein Weilchen dauern bis ich das alles geschafft habe)
und werde dann deinen Code anwenden.

Vielen Dank
:-)
Stefan

P.S. wenn das mit der Namensgebung das Problem ist, dann hab ich evtl. auch für meinen 2ten Beitrag die Lösung...
Vielen Dank


  

Betrifft: AW: shapes kopieren von: stef26
Geschrieben am: 15.08.2014 08:04:16

Hallo Karin,
ich bräuchte nochmal Hilfe ich hab gesehen, dass hinter dem Namen die Längen stehen und diese für spätere Berechnungen verwendet werden. Dies alles Umzuschreiben ist enormer Aufwand.
Einfacher für mich wäre alle Shape Namen so abzuändern, dass eine laufende Nummer am Anfang jedes shapes in Klammern gestellt wird:
(345)Shapenameblabla länge: 15,43m
Wie müsste dann dein Code aussehen ?

Liebe Grüße
STefan


  

Betrifft: AW: shapes kopieren von: Beverly
Geschrieben am: 15.08.2014 08:17:18

Hi Stefan,

alle Shapes mit der laufenden Nummer 1 versehen kannst du mit folgendem Code:

Sub ShapesNummerieren()
   Dim shaSape As Shape
   For Each shaShape In ActiveSheet.Shapes
      shaShape.Name = "(1)" & shaShape.Name
   Next shaShape
End Sub
Der Code für das Gruppieren müsste dann so aussehen:
         strName = Mid(shaShape.Name, InStr(shaShape.Name, ")") + 1)
         lngShape = Mid(shaShape.Name, 2, InStr(shaShape.Name, ")") - 2)
         shaShape.Name = "(" & lngShape + 1 & ")" & strName

GrußformelBeverly's Excel - Inn


  

Betrifft: AW: shapes kopieren von: stef26
Geschrieben am: 15.08.2014 11:30:59

Hallo Karin,
besten Dank mit den geänderten Shapenamen funktioniert es wie ich mir das vorgestellt habe

Vielen herzlichen dank dafür

Leider muss ich eine Abfrage ändern und weiss nicht genau wie.

Hab dazu ein neuen Beitrag gemacht, da dieser ja zu 100% von dir gelöst wurde

Wie schon gesagt vielen vielen Dank dafür

Liebe Grüße
Stefan


 

Beiträge aus den Excel-Beispielen zum Thema "shapes kopieren"