Live-Forum - Die aktuellen Beiträge
Datum
Titel
24.04.2024 20:38:58
Summe mit Bedingung, nur letzte Ergebnisse anzeigen
24.04.2024 19:29:30
Formel filter
24.04.2024 18:49:56
merge & select
24.04.2024 17:19:09
Formel mit Index-Funktion
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1376to1380
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1376to1380
1376to1380
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

shapes kopieren

shapes kopieren
14.08.2014 08:24:13
stef26
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

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: shapes kopieren
14.08.2014 10:22:23
Beverly
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

Anzeige
AW: shapes kopieren
14.08.2014 18:41:38
stef26
super
BESTEN DANK
Liebe Grüße
Stefan

AW: shapes kopieren
14.08.2014 21:04:26
stef26
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

Anzeige
AW: shapes kopieren
14.08.2014 22:38:27
Beverly
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

Anzeige
AW: shapes kopieren
15.08.2014 07:36:53
stef26
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

AW: shapes kopieren
15.08.2014 08:04:16
stef26
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

Anzeige
AW: shapes kopieren
15.08.2014 08:17:18
Beverly
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

Anzeige
AW: shapes kopieren
15.08.2014 11:30:59
stef26
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

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige