使用活動單元格的值超鏈接（或 VBA）到同一工作簿中另一工作表上的相同值

Question

我是一個相當高級的 excel 用戶，但在 VBA 編碼方面經驗有限； 誰能幫我一把，或者讓我朝着正確的方向前進？

我有兩張帶桌子的床單：

第一張 (MASTER) 表包含產品信息，其中包括唯一的庫存代碼 (SKU)； 它還將可用作第一個產品替代品的任何產品的 SKU 標識為單獨的列條目。 MASTER 產品和潛在的 SUBSTITUTE 產品的產品詳細信息都在這個 MASTER 工作表中。

第二個 (SUBSTITUTE) 表被過濾以顯示具有潛在替代品的產品以及該潛在替代品的 SKU。 它從 MASTER 工作表和表格中獲取此信息。

我希望能夠 select 替代表上的潛在替代 SKU 單元格，然后使用超鏈接或使用 VBA 以使用該值跳轉到主表中與替代單元格中的值相同的單元格。

總結偽代碼是：

1. Go 到 SUBSTITUTE 工作表
2. 在表中定位/選擇 SKU 代碼
3. 編碼將從這里開始。 （VBA 或超鏈接）
4. 獲取該單元格的值並存儲為變量
5. 跳轉到主工作表
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

激活另一個工作表上的單元格

• 調整常量部分中的值。
• 這會自動運行（自行運行），無需手動運行。
• 當您 select 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