Hyperlink auf Sheets, ausgehend von Rechtecksform

Hallo zusammen,

nach dem mir neulich schonmal so toll in dieser Community geholfen wurde, komme ich auch jetzt mal wieder auf euch zurück...

Ich habe folgendes Anliegen:

Ich möchte gerne eine Excel-Arbeitsmappe gestalten, bei der auf dem ersten Tabellenblatt (ganz links in der Tab-Leiste) ein Prozessfluss aus einzelnen Rechtecksformen und Verbindungslinien (nicht in Zellen, sondern wirklich als "Formelement") entsteht. Da für möchte ich gerne ein Makro programmieren, dass folgende Steps nacheinander automatisch ausführt und das beliebig oft ausgeführt werden kann:

- Erstelle eine Rechtecksform
- Schreibe dort hinein den Text "", der als allgemeiner Platzhalter dient und manuell im Nachgang noch editiert werden soll
- Erstelle ein neues Tabellensheet ganz rechts in der Tab-Leiste. Die Tabellenblätter in der Tab-Leiste sollen einfach mit laufenden Nummern 1, 2, 3, ...100 automatisch benannt werden
- Erstelle einen Link, der Beim Klick auf die erstellte Rechtecksform (oder den darin befindlichen Text, das ist egal) auf das neu erzeugte Tabellensheet springt

Wichtig: Die Erzeugung eines Rechtecks inkl. neuem Tabellensheet und passender Verlinkung soll häufig nacheinander wiederholbar sein

Ich beschäftige mich erst seit Kurzem mit Excel/ VBA und bin mir hier deswegen leider unsicher in der Umsetzung... Mein bisheriger Code, den ich mir bisher "zusammengebastelt" habe, funktioniert zwar soweit, aber ich bekomme aber die Verlinkung nicht ergänzt...

Kann mir hier einer weiterhelfen?

Mein Code sieht bisher so aus:



Sub Form_und_Sheet()





'Form generieren und Formatieren

        

    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 80, 55, 100, 42).Select

    With Selection.ShapeRange.Fill

        .Visible = msoTrue

        .ForeColor.ObjectThemeColor = msoThemeColorBackground1

        .ForeColor.TintAndShade = 0

        .ForeColor.Brightness = -0.25

        .Transparency = 0

        .Solid

    End With

    With Selection.ShapeRange.Line

        .Visible = msoTrue

        .ForeColor.ObjectThemeColor = msoThemeColorText1

        .ForeColor.TintAndShade = 0

        .ForeColor.Brightness = 0

        .Transparency = 0

    End With

    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle

       

'Neues Tabellenblatt ganz rechts in Tab-Leiste erzeugen

    Sheets.Add After:=Sheets(Sheets.Count)

    

       

'Rücksprung zu Prozessübersicht MASTER

    Sheets("Master").Select

    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _

        ""

    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 34). _

        ParagraphFormat

        .FirstLineIndent = 0

        .Alignment = msoAlignCenter

    End With

    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 34).Font

        .NameComplexScript = "+mn-cs"

        .NameFarEast = "+mn-ea"

        .Fill.Visible = msoTrue

        .Fill.ForeColor.RGB = RGB(0, 0, 0)

        .Fill.Transparency = 0

        .Fill.Solid

        .Size = 11

        .Name = "+mn-lt"

    End With



   



'Tabellenblätter fortlaufend nummerieren

    Dim a As Integer

    Dim AnzahlSheets As Integer

    Application.ScreenUpdating = 0

    AnzahlSheets = ActiveWorkbook.Worksheets.Count

    For a = 2 To AnzahlSheets

    Sheets(a).[b1] = a

    Sheets(a).Name = a

    Next

    Application.ScreenUpdating = -1

    End



End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim objWorksheet As Worksheet Dim objActiveSheet As Worksheet Dim objShape As Shape Set objActiveSheet = ActiveSheet Set objShape = objActiveSheet.Shapes.AddShape(msoShapeRectangle, 80, 55, 100, 42) With objShape With .Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = -0.25 .Transparency = 0 .Solid End With With .Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 End With End With Set objWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count)) Call objActiveSheet.Hyperlinks.Add(Anchor:=objShape, Address:="", SubAddress:=objWorksheet.Cells(1, 1).Address(External:=True)) Set objWorksheet = Nothing Set objActiveSheet = Nothing Set objShape = Nothing '.... End Sub

Sub Prozess_hinzufügen() Dim objWorksheet As Worksheet Dim objActiveSheet As Worksheet Dim objShape As Shape Set objActiveSheet = ActiveSheet Set objShape = objActiveSheet.Shapes.AddShape(msoShapeRectangle, 80, 55, 100, 42) With objShape With .Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = -0.25 .Transparency = 0 .Solid End With With .Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 End With ' Bearbeiten und Formatieren des Texts innerhalb der Rechtecksform With objShape.TextFrame.Characters .Text = "" ' Text ändern .Font.Color = RGB(0, 0, 0) ' Textfarbe auf Schwarz setzen .Font.Size = 11 ' Schriftgröße auf 11 setzen End With With objShape.TextFrame2.TextRange .ParagraphFormat.Alignment = msoAlignCenter ' Zentrierte Ausrichtung des Absatzes End With With objShape.TextFrame2 .VerticalAnchor = msoAnchorMiddle End With 'Mittige Ausrichtung des Textes innerhalb des Absatz End With 'Erstellen des Hyperlinks Set objWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count)) Call objActiveSheet.Hyperlinks.Add(Anchor:=objShape, Address:="", SubAddress:=objWorksheet.Cells(1, 1).Address(External:=True)) 'Freigeben der Objektvariablen, um Speicherplatz freizugeben Set objWorksheet = Nothing Set objActiveSheet = Nothing Set objShape = Nothing 'Rücksprung zu Prozessübersicht MASTER Sheets("1-Prozessübersicht").Select 'Tabellenblätter fortlaufend nummerieren Dim a As Integer Dim AnzahlSheets As Integer Application.ScreenUpdating = 0 AnzahlSheets = ActiveWorkbook.Worksheets.Count For a = 2 To AnzahlSheets Sheets(a).[b1] = a Sheets(a).Name = a Next Application.ScreenUpdating = -1 End End Sub

Option Explicit Sub test() Dim objWorksheet As Worksheet Dim objActiveSheet As Worksheet Dim objShape As Shape Dim a As Long, AnzahlSheets As Long Set objActiveSheet = ActiveSheet Set objShape = objActiveSheet.Shapes.AddShape(msoShapeRectangle, 80, 55, 100, 42) With objShape With .Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = -0.25 .Transparency = 0 .Solid End With With .Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 End With End With Set objWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count)) Application.ScreenUpdating = False AnzahlSheets = ActiveWorkbook.Worksheets.Count For a = 2 To AnzahlSheets Worksheets(a).Cells(1, 2).Value = a Worksheets(a).Name = a Next Application.ScreenUpdating = True Call objActiveSheet.Hyperlinks.Add(Anchor:=objShape, Address:="", SubAddress:=objWorksheet.Cells(1, 1).Address(External:=True)) Set objWorksheet = Nothing Set objActiveSheet = Nothing Set objShape = Nothing '.... End Sub

Beliebteste Forumthreads (12 Monate)

Hyperlink auf Sheets, ausgehend von Rechtecksform

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread