VBA 创建指向另一个动态工作簿的超链接

Question

我正在努力寻找解决问题的方法：

我有一个工作簿上的项目列表和一个为不同电子表格上的每个项目创建工作表的宏。

A 列中的每个代码都将产品类型作为第一个字母，每个产品类型都有自己的工作簿。

所有代码都可以正常工作，除了超链接。

我需要在创建工作表时将每个代码超链接到工作表。

运行时，它会将我的单元格超链接到“C:\Users\Reception\Documents\Shared\Item Master Data\Stock\”，而不是打开我的工作表。

我错过了什么？我的完整代码如下。

Sub StockSheets()

        Sheets("Component List").Select
          Range("A2").Select 'Start with first item code'

    Do Until ActiveCell = " "

          GoTo Openwb 'check if wbStock is already open'

NewType: 'if wbStock is not open'

          Dim StType As String, wbStock As Workbook, wsTEMP As Worksheet

                If Left(ActiveCell, 1) = "B" Then
                    StType = "Bulk Stock.xlsx"

                Else
                    If Left(ActiveCell, 1) = "F" Then
                        StType = "Finished Goods Stock.xlsx"

                        Else
                            If Left(ActiveCell, 1) = "P" Then
                                StType = "Packaging Stock.xlsx"

                                Else
                                    If Left(ActiveCell, 1) = "R" Then
                                        StType = "Raw Mat Stock.xlsx"
                                    End If
                            End If
                    End If
            End If

            Set wbStock = Workbooks.Open("C:\Users\Reception\Documents\Shared\Item Master Data\Stock\" & StType)

Resume Cont1 'skip Openwb part'

Openwb:

On Error GoTo NewType 'Open wbStock'

        wbStock.Activate

Cont1:

            Set wsTEMP = Sheets("Stock Template")

        wsTEMP.Copy After:=Sheets(Sheets.Count) 'Copies the Stock template to a new sheet'

        Sheets(Sheets.Count).Activate

        Application.Workbooks("Item Master Data.xlsm").Activate
            Worksheets("Component List").Select

On Error GoTo Exist 'if Sheetname exists'

        wbStock.Worksheets("Stock Template (2)").Name = ActiveCell.Value 'Name the new sheet as per the active cell on Component List'

        wbStock.Activate

        Range("A1:B1").Copy
            Range("A1:B1").PasteSpecial Paste:=xlPasteValues 'Paste the formulas as values to speed up computer'

        Range("A:J").Select
        Columns.AutoFit 'neaten the sheet'

        ThisWorkbook.Activate 'Go back to Item Master Data workbook with Component list'

        Dim FPath As String
            FPath = "C:\Users\Reception\Documents\Shared\Item Master Data\Stock\" & StType

        Sheets("Component List").Hyperlinks.Add Anchor:=Excel.Selection, _
            Address:="C:\Users\Reception\Documents\Shared\Item Master Data\Stock\" & StType & "#" & ActiveCell.Value & "!A1" 'Hyperlink item code to newly created sheet on wbStock'

Cont2:

        If Left(ActiveCell.Offset(1, 0), 1) = Left(ActiveCell, 1) Then
Resume Cont3 'Check if next stType is the same as the Active Cell'

            Else
                wbStock.Close True 'Save and close wbStock'
        End If

Cont3:

        ActiveCell.Offset(1, 0).Select 'Select next item'

    Loop

Exist: 'If the sheet already exists'

            Sheets("Componet List").Hyperlinks.Add Anchor:=Selection, _
            Address:=wbStock.Worksheets(ActiveCell).Range("A1")

            Application.DisplayAlerts = False
                Worksheets("Stock Template (2)").Delete
            Application.DisplayAlerts = True 'Delete the newly created sheet before looping with the next item'

Resume Cont2 

        ActiveSheet.Cells.Font.Size = 10 'Neaten Sheet'

            Range("A1").Select
            Range(Selection, Selection.End(xlToRight)).Select
            Range(Selection, Selection.End(xlDown)).Select

        With Selection.Borders
            .LineStyle = xlContinuous
            .Color = 0
            .Weight = xlThin
        End With

        With Columns("A:ZZ").AutoFit
            Range("A1").Select
        End With

End Sub

Answer 1

您应该使用Select Case 来确保您的条件匹配。

在超链接中添加SubAddress 应该可以让您到达正确的工作表。
如果名称中有空格，则必须在工作表名称周围添加'。

您应该避免使用ActiveCell 或Select，至少可以说它们效率不高。

Dim StType As String, FPath As String
Select Case Left(ActiveCell, 1)
    Case Is = "B"
        StType = "Bulk Stock.xlsx"
    Case Is = "F"
        StType = "Finished Goods Stock.xlsx"
    Case Is = "P"
        StType = "Packaging Stock.xlsx"
    Case Is = "R"
        StType = "Raw Mat Stock.xlsx"
    Case Else
        MsgBox "Case not handled for type : " & Left(ActiveCell, 1), _
                vbOKOnly + vbInformation
        Exit Sub
End Select

FPath = "C:\Users\Reception\Documents\Shared\Item Master Data\Stock\" & StType

Sheets("Component List").Hyperlinks.Add _
    Anchor:=ActiveCell, _
    Address:=FPath, _
    SubAddress:=ActiveCell.Value & "!A1"

Answer 2

您为什么不使用公式而不是宏来创建超链接，因为从您的代码看来，您一次调用一次就运行宏。

此示例假定您的代码在 A 列中。将公式放在另一列的第一行，然后自动填充以创建所有代码的超链接。我只包含了前几个文件，这样操作起来不会太复杂，但您只需要添加其他嵌套的 ifs。

=IF(LEFT(A1,1)="B",HYPERLINK("C:\Users\Reception\Documents\Shared\Item Master Data\Stock\Bulk Stock.xlsx","Bulk Stock.xlsx"),IF(LEFT(A1,1)="F",HYPERLINK("C:\Users\Reception\Documents\Shared\Item Master Data\Stock\Finished Goods Stock.xlsx","Finished Goods Stock.xlsx"),""))

这是所有嵌套荣耀中的整个公式。

=IF(LEFT(A1,1)="B",HYPERLINK("C:\Users\Reception\Documents\Shared\Item Master Data\Stock\Bulk Stock.xlsx","Bulk Stock.xlsx"),IF(LEFT(A1,1)="B",HYPERLINK("C:\Users\Reception\Documents\Shared\Item Master Data\Stock\Bulk Stock.xlsx","Bulk Stock.xlsx"),IF(LEFT(A1,1)="P",HYPERLINK("C:\Users\Reception\Documents\Shared\Item Master Data\Stock\Packaging Stock.xlsx","Packaging Stock.xlsx"),IF(LEFT(A1,1)="R",HYPERLINK("C:\Users\Reception\Documents\Shared\Item Master Data\Stock\Raw Mat Stock.xlsx","Raw Mat Stock.xlsx"),""))))