VBA创build超链接到另一个dynamic工作簿

我正在努力为我的问题find一个解决scheme：

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

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

所有的代码工作正常，除了超链接。

创build时，我需要将每个代码超链接到表格。

运行时，它将我的单元格超链接到“C：\用户\接待\文件\共享\项目主数据\股票\”不打开我的工作表。

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

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他们是没有效率的说至less。

 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

为什么不使用公式来创build超链接，而不是像你的代码那样创build一个macros，它看起来就像一次调用一个macros一样。

这个例子假设你的代码在列A中，把公式放在另一列的第一行，然后自动填充以创build所有代码的超链接。 我只包含了第一个文件，所以它不是太复杂，但你只需要添加其他嵌套的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"),""))))