添加一個「家」的超鏈接使用VBA

Question

這個問題的形狀之前已經問，但我找到了解決辦法似乎沒有工作，不管我怎麼努力 - 這是我的問題：

我有幾個工作表一本工作手冊。我創建了一個宏，它創建一個按鈕（使用一個形狀）並在它上面放置一個超鏈接到名爲「Crawl Summary」的書中的第一個表格。宏然後將該按鈕放在書中的每個其他工作表上。

所記錄的宏是這樣的：

'Creates a navigation button back to Crawl Summary Page on each page 

    Sheets("Robots.txt Blocked").Select 
    Range("A1").Select 
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 0, 1.2, 52.2, 13.2). _ 
     Select 
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "SUMMARY" 
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 7). _ 
     ParagraphFormat 
     .FirstLineIndent = 0 
     .Alignment = msoAlignLeft 
    End With 
    With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 7).Font 
     .NameComplexScript = "+mn-cs" 
     .NameFarEast = "+mn-ea" 
     .Fill.Visible = msoTrue 
     .Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1 
     .Fill.ForeColor.TintAndShade = 0 
     .Fill.ForeColor.Brightness = 0 
     .Fill.Transparency = 0 
     .Fill.Solid 
     .Size = 11 
     .Name = "+mn-lt" 
    End With 
    Selection.ShapeRange.ScaleWidth 1.9540229885, msoFalse, msoScaleFromTopLeft 
    Selection.ShapeRange.ScaleHeight 0.9090909091, msoFalse, msoScaleFromTopLeft 
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle 
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _ 
     msoAlignCenter 
    Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue 
    ActiveSheet.Shapes.Range(Array("Rounded Rectangle 1")).Select 
    ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="" 
    Selection.Copy 
    Sheets("Noindexed Pages").Select 
    Range("A1").Select 
    ActiveSheet.Paste 

正如你可以看到，該代碼與按鈕被複制到被稱爲「Noindexed頁」下一個工作表結束，但對於上述兩個頁面的超鏈接是不應用。

這顯然是因爲這個答案＃1的解釋：

Excel VBA add hyperlink to shape to link to another sheet

此頁面上給出的推薦的解決方案如下：

Sub SetHyperlinkOnShape() 
    Dim ws As Worksheet 
    Set ws = ThisWorkbook.Sheets("Sheet6") 

    Dim hyperLinkedShape As Shape 

    Set hyperLinkedShape = ws.Shapes("Rounded Rectangle 1") 

    ws.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:="", _ 
     SubAddress:="Sheet4!C4:C8", ScreenTip:="yadda yadda" 
End Sub 

但是，這是行不通的無論我嘗試什麼，即使我創建

任何人都可以建議我需要什麼代碼來成功添加我內部超鏈接到活動工作表中按鈕（形狀）上的「抓取摘要」？

Answer 1

I.確保在名爲「工作表6」的工作表中有一個名爲「Rounded Rectangle 1」的形狀。

II。確保你有Sheet1。

差不多這個代碼的工作（從你的拍攝）：

Option Explicit 

Sub SetHyperlinkOnShape() 


    Dim ws As Worksheet 
    Set ws = ThisWorkbook.Sheets("Sheet6") 

    Dim hyperLinkedShape As Shape 

    Set hyperLinkedShape = ws.Shapes("Rounded Rectangle 1") 

    ws.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:="", _ 
     SubAddress:="Sheet1!C4:C8", ScreenTip:="yadda yadda" 
End Sub 

這裏是一個快速的方法來創建宏錄製的形狀具有指定名稱：

Sub Makro1() 
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 104.4000787402, 42.75, _ 
     3.5999212598, 5.25).Select 
    Selection.ShapeRange.Name = "JoeBanana3" 
End Sub 

Answer 2

你需要使用表格和範圍的SubAddress屬性，
和Address屬性以及文件的FullName（路徑+名稱），
和Anchor使用創建/粘貼的對象（Set sH = ...）

wS.Hyperlinks.Add Anchor:=sH, _ 
        Address:="C:\TestFolder\TestFile.xlsm", _ 
        SubAddress:="'Sheets name'!A1", _ 
        ScreenTip:="Go to home" 

創建一個導航按鈕，以抓取摘要頁（適當的縮進和Select小號清潔的）：

Dim wS As Worksheet 
Dim sH As Shape 

Set wS = ThisWorkbook.Sheets("Robots.txt Blocked") 

Set sH = wS.Shapes.AddShape(msoShapeRoundedRectangle, 0, 1.2, 52.2, 13.2) 

With sH 
    With .ShapeRange(1).TextFrame2.TextRange 
     .Characters.Text = "SUMMARY" 
     With .Characters(1, 7) 
      With .ParagraphFormat 
       .FirstLineIndent = 0 
       .Alignment = msoAlignLeft 
      End With '.ParagraphFormat 
      With .Font 
       .NameComplexScript = "+mn-cs" 
       .NameFarEast = "+mn-ea" 
       With .Fill 
        .Visible = msoTrue 
        .ForeColor.ObjectThemeColor = msoThemeColorLight1 
        .ForeColor.TintAndShade = 0 
        .ForeColor.Brightness = 0 
        .Transparency = 0 
        .Solid 
       End With '.Fill 
       .Size = 11 
       .Name = "+mn-lt" 
      End With '.Font 
     End With '.Characters(1, 7) 
    End With ' 
    With .ShapeRange 
     .ScaleWidth 1.9540229885, msoFalse, msoScaleFromTopLeft 
     .ScaleHeight 0.9090909091, msoFalse, msoScaleFromTopLeft 
     With .TextFrame2 
      .VerticalAnchor = msoAnchorMiddle 
      .TextRange.ParagraphFormat.Alignment = msoAlignCenter 
      .TextRange.Font.Bold = msoTrue 
     End With '.TextFrame2 
    End With '.ShapeRange 
End With 'sH 

wS.Hyperlinks.Add Anchor:=sH, _ 
        Address:="C:\TestFolder\TestFile.xlsm", _ 
        SubAddress:="'Crawl Summary'!A1", _ 
        ScreenTip:="Go to home" 
sH.Copy 
Set sH = Sheets("Noindexed Pages").Range("A1").Paste 
'... Check if hyperlink is still ok or reuse above code