使用活动单元格的值将超链接（或 VBA）链接到同一工作簿中另一张工作表上的相同值

Question

我是一个相当高级的 excel 用户，但在 VBA 编码方面的经验有限；谁能帮帮我，或者请让我朝正确的方向前进？

我有两张表格：

第一个 (MASTER) 表包含包含唯一库存代码 (SKU) 的产品信息；它还将任何产品的 SKU 标识为单独的列条目，该 SKU 可用作第一个产品的替代品。 MASTER 产品的产品详细信息和潜在的 SUBSTITUTE 产品都在此 MASTER 工作表中。

第二个 (SUBSTITUTE) 表被过滤以显示具有潜在替代品的产品以及该潜在替代品的 SKU。它从 MASTER 工作表和表格中获取此信息。

我希望能够在 SUBSTITUTE 表上选择潜在的替代 SKU 单元格，然后使用超链接或使用 VBA 使用该值跳转到 MASTER 表中与 SUBSTITUTE 具有相同值的单元格细胞。

总之伪代码是：

1. 转到 SUBSTITUTE 工作表
2. 在表中的 SKU 代码上定位/选择
3. 编码将从这里开始。 （VBA 或超链接）
4. 获取该单元格的值并将其存储为变量
5. 跳转到 MASTER 工作表
6. 在 SKU 列中查找变量的值（SKU 是唯一的）
7. 使与变量具有相同值的单元格成为活动单元格

可以吗？

提前致谢

Answer 1

特里，下面的宏可以满足您的大部分需求。您可以为此宏创建键盘快捷键，每次运行宏时，它都会在您选择的（SUBSTITUTE-sheet）单元格中搜索文本，在您的 Excel 文件中的 MASTER 表中，并将其显示给您.之后，您可以手动更改数据，也可以根据需要编辑宏。请参阅下面的示例屏幕截图。

Sub Macro4()
    my_text = Selection.Value
    Sheets("MASTER").Activate
    Cells.Select
    On Error GoTo my_err
    Selection.Find(What:=my_text, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Exit Sub
my_err: MsgBox "search text not found"
        Sheets("SUBSTITUTE").Select
    
End Sub

Answer 2

激活另一个工作表上的单元格

• 调整常量部分中的值。
• 它会自动运行（自行），无需手动运行。
• 当您在Substitute 工作表中选择SKU 单元格时，它会激活Master 工作表中包含相同SKU 值的单元格，使其成为最顶部和最左侧的单元格（必要时进行修改)。

表格模块，例如Substitute

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    SelectSKU Target
End Sub

标准模块，例如Module1

Option Explicit

Sub SelectSKU(ByVal Target As Range)
    
    ' Source
    Const shRow As Long = 1
    Const sTitle As String = "SKU"
    ' Destination
    Const dName As String = "Master"
    Const dhRow As Long = 1
    Const dTitle As String = "SKU"
    
    ' Source
    
    If Target Is Nothing Then Exit Sub
    Dim ws As Worksheet: Set ws = Target.Worksheet
    If shRow < 1 Then Exit Sub ' Source Header Row too small
    If shRow >= ws.Rows.Count Then Exit Sub ' Source Header Row too great
    
    Dim shCell As Range: Set shCell = RefHeader(ws, sTitle, shRow)
    If shCell Is Nothing Then Exit Sub ' Source Header not found
    
    Dim scrg As Range: Set scrg = RefColumn(shCell.Offset(1))
    If scrg Is Nothing Then Exit Sub ' Source Range is empty
    
    Dim sCell As Range: Set sCell = Intersect(Target.Cells(1), scrg)
    If sCell Is Nothing Then Exit Sub ' cell not in Source Range
    If IsError(sCell) Then Exit Sub ' cell contains an error
    If Len(sCell.Value) = 0 Then Exit Sub ' cell is blank i.e. no SKU value
    
    Dim sValue As String: sValue = CStr(sCell.Value)
    
    ' Destination
    
    If dhRow < 1 Then Exit Sub ' Destination Header Row too small
    If dhRow >= ws.Rows.Count Then Exit Sub ' Destination Header Row too great
    
    Dim dws As Worksheet: Set dws = RefWorksheet(ws.Parent, dName)
    If dws Is Nothing Then Exit Sub ' Destination Worksheet not found
    
    Dim dhCell As Range: Set dhCell = RefHeader(dws, dTitle, dhRow)
    If dhCell Is Nothing Then Exit Sub ' Destination Header not found
    
    Dim dcrg As Range: Set dcrg = RefColumn(dhCell.Offset(1))
    If scrg Is Nothing Then Exit Sub ' Destination Range is empty
    
    Dim dcell As Range: Set dcell = dcrg.Find(sValue, _
        dcrg.Cells(dcrg.Cells.Count), xlFormulas, xlWhole)
    If dcell Is Nothing Then Exit Sub ' SKU not found in Destination Range
    
    dws.Activate
    dcell.Activate
    
    ' Optional. Remove or modify one or both if you don't like it.
    With ActiveWindow
        .ScrollRow = dcell.Row
        .ScrollColumn = dcell.Column
    End With
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a row ('HeaderRow') of a worksheet ('ws'), creates
'               a reference to the first cell whose value is equal
'               to a string ('Title'). Case-insensitive.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefHeader( _
    ByVal ws As Worksheet, _
    ByVal Title As String, _
    Optional ByVal HeaderRow As Long = 1) _
As Range
    If ws Is Nothing Then Exit Function
    If HeaderRow < 1 Then Exit Function
    If HeaderRow > ws.Rows.Count Then Exit Function
    With ws.Rows(HeaderRow)
        Set RefHeader = .Find(Title, .Cells(.Cells.Count), xlFormulas, xlWhole)
    End With
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('rg') through the bottom-most non-empty cell.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal rg As Range) _
As Range
    If rg Is Nothing Then Exit Function
    With rg.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In a workbook ('wb'), creates a reference to the worksheet
'               named after a string ('WorksheetName').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefWorksheet( _
    ByVal wb As Workbook, _
    ByVal WorksheetName As String) _
As Worksheet
    If wb Is Nothing Then Exit Function
    On Error Resume Next
    Set RefWorksheet = wb.Worksheets(WorksheetName)
    On Error GoTo 0
End Function