在列表中查找单元格值，然后从列表中选择该单元格

我需要查找的范围 - 使用 Range.Find

Option Explicit

Sub PlaceHyperlinks()

    Dim wb As Workbook, ws As Worksheet
    Dim cel As Range, fnd As Range
    Dim CurrMth As String, sht As String
    Dim lastrow As Long, n As Long
    
    Set wb = ThisWorkbook
    With wb.Sheets("Hyperlinks")

        'CurrMth = Current Month
        CurrMth = .Range("E1").Value
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        For Each cel In .Range("A10:A" & lastrow)
            sht = cel.Value
            On Error Resume Next
            Set ws = wb.Sheets(sht)
            On Error GoTo 0
            If ws Is Nothing Then
                MsgBox "Sheet " & sht & " not found", vbCritical
                Exit Sub
            End If
            
            Set fnd = ws.Range("V:V").Find(CurrMth, LookIn:=xlValues, lookat:=xlWhole)
            If fnd Is Nothing Then
                MsgBox CurrMth & " not found on " & sht, vbCritical
                Exit Sub
            Else
                ' hyperlink in column W
                fnd.Offset(, 1).Value = cel.Offset(, 3)
                n = n + 1
            End If
            Set ws = Nothing
        Next
    End With
    MsgBox n & " links updated for " & CurrMth, vbInformation

End Sub

感谢您的帮助。这是完整的解决方案，也给了我预期的结果。我能够通过部分代码来做到这一点。For Each moncell

这使我能够找到我选择的月份，然后粘贴到我正在浏览的每张纸上范围内的相同值旁边。currmonV2:V13

Sub PlaceHyperlinks()

Worksheets("Hyperlinks").Activate

'CurrMon = Current Month
Dim CurrMon As String
CurrMon = Range("E1").Value

Dim cell As Range
Dim sht As String
Dim MonList As Range

For Each cell In Range("A10:A21")
    sht = cell.Value
    'copy hyperlink cell
    cell.Offset(, 3).Copy
    
    'go to target sheet
    Worksheets(sht).Activate
    Set MonList = Range("V2:V13")
    
    'lookup date CurrMon from MonList
    Dim moncell As Range
    For Each moncell In MonList
        If moncell = CurrMon Then
            moncell.Offset(, 1).PasteSpecial
        End If
    Next moncell
    
    'go back to Hyperlinks sheet
    Worksheets("Hyperlinks").Activate
Next cell

'clear copy selection
Application.CutCopyMode = False

End Sub

复制列表中每个工作表的查找值

源

• 在源工作表中，我有一个范围中的工作表名称列表。HyperlinksA10:A_lr
• 对于列表中的每个工作表，我需要复制列中的相应值。D
• 我在单元格中也有一个查找值。E1

目的地

• 在每个目标工作表中，我都有一个范围内的值列表V2:V13
• 我需要在该范围内找到查找值，并在同一行中将复制的值粘贴到列中。W

Sub CopyThisMonthsData()

    Const SRC_SHEET_NAME As String = "Hyperlinks"
    Const SRC_SHEET_NAMES_FIRST_CELL As String = "A10"
    Const SRC_LOOKUP_CELL As String = "E1" ' month
    Const SRC_RETURN_COLUMN As String = "D"
    
    Const DST_LOOKUP_RANGE As String = "V2:V13" ' 12 months
    Const DST_RETURN_COLUMN As String = "W"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    Dim slValue As Variant: slValue = sws.Range(SRC_LOOKUP_CELL).Value
    Dim srg As Range:
    With sws.Range(SRC_SHEET_NAMES_FIRST_CELL)
        Set srg = sws.Range(.Cells, sws.Cells(sws.Rows.Count, .Column).End(xlUp))
    End With
    
    Dim slcell As Range, srcell As Range
    Dim dws As Worksheet, drg As Range, drcell As Range, drIndex As Variant
    
    For Each slcell In srg.Cells
        On Error Resume Next
            Set dws = wb.Sheets(CStr(slcell.Value))
        On Error GoTo 0
        If Not dws Is Nothing Then
            Set drg = dws.Range(DST_LOOKUP_RANGE)
            drIndex = Application.Match(slValue, drg, 0)
            If IsNumeric(drIndex) Then
                Set srcell = slcell.EntireRow.Columns(SRC_RETURN_COLUMN)
                Set drcell = drg.Cells(drIndex) _
                    .EntireRow.Columns(DST_RETURN_COLUMN)
                ' Copy values, formats and formulas.
                srcell.Copy drcell
                ' Copy values only (more efficient).
                'drcell.Value = srcell.Value
            End If
        End If
    Next slcell

    MsgBox "This month's data copied.", vbInformation

End Sub