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"),""))))