使用VBA将“主页”超链接添加到形状

这个问题之前已经问过，但我发现的解决scheme似乎并不工作，无论我尝试 – 这是我的问题：

我有一个工作簿中的几个工作表。 我创build了一个macros，它创build一个button（使用一个形状），并将超链接放在名为“抓取摘要”的书中的第一张纸上。 macros然后将该button放在书中的每个其他工作表上。

logging的macros是这样的：

'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 Pages”的下一个工作表的button结束，但上述两个页面的超链接不适用。

这显然是因为这个Stackoverflow的答案解释：

Excel VBA添加超链接来塑造链接到另一个工作表

本页给出的build议解决scheme如下：

 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 

但是，即使我创作，无论我尝试什么，这都不适合我

任何人都可以build议我需要什么代码，以成功地添加到活动工作表中的button（形状）上的“抓取摘要”的内部超链接？

Answer 1

I.确保在名为“工作表6”的工作表中有一个称为“圆angular矩形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 

这是一个快速的方法来从macros录制器创build一个具有指定名称的形状：

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

Answer 2

您将需要使用Sheet和Range的SubAddress属性，
和Address属性与文件的FullName（path+名称）
作为Anchor使用您创build/粘贴的对象（ Set sH = ... ）

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

创build“抓取摘要”页面的导航button（正确缩进并清除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