英文:
Hyperlinking multiple columns to the same cell in another worksheet
问题
我正在尝试将包含值的第4行到第14行的单元格C到I创建超链接到另一个包含值的单列A的工作表。
我希望这些值匹配并创建超链接，例如，我点击单元格C4，它会直接链接到另一个工作表的相应单元格。
有没有办法实现这个目标？
尝试使用以下VBA代码：
Sub AddHyperlinks2()
Dim i As Long, Lr1 As Long, Lr2 As Long, Cr As Long, CrA As String
Lr1 = Sheets("APRILZ").Range("C" & Rows.Count).End(xlUp).Row
Lr2 = Sheets("DATABASE").Range("D" & Rows.Count).End(xlUp).Row
On Error GoTo NextC
For i = 2 To Lr1
On Error GoTo NextC
Cr = Application.WorksheetFunction.Match(Range("C" & i).Value, Sheets("DATABASE").Range("D1:D" & Lr2), 0)
CrA = Range("D" & Cr).Address
Sheets("APRILZ").Hyperlinks.Add Anchor:=Sheets("APRILZ").Range("C" & i), Address:="", SubAddress:= _
"'" & Sheets("DATABASE").Name & "'!" & CrA, TextToDisplay:=Sheets("DATABASE").Range("D" & i).Value
NextC:
Resume NextD
NextD:
Next i
End Sub
但是这只会创建第一个单元格C4的超链接，因为其他单元格具有重复的值。
英文:
I am trying to hyperlink Cells C to I from Rows 4 to 14 which all contains values to another sheet with a singular column in A that contains values.
I want the values to match and be hyperlinked, e.g I click on Cell C4 and it links me directly to the other sheet and to the direct cell.
Is there any way to do this?
Have tried using this VBA Code:
Sub AddHyperlinks2()
Dim i As Long, Lr1 As Long, Lr2 As Long, Cr As Long, CrA As String
Lr1 = Sheets("APRILZ").Range("C" & Rows.Count).End(xlUp).Row
Lr2 = Sheets("DATABASE").Range("D" & Rows.Count).End(xlUp).Row
On Error GoTo NextC
For i = 2 To Lr1
On Error GoTo NextC
Cr = Application.WorksheetFunction.Match(Range("C" & i).Value, Sheets("DATABASE").Range("D1:D" & Lr2), 0)
CrA = Range("D" & Cr).Address
Sheets("APRILZ").Hyperlinks.Add Anchor:=Sheets("APRILZ").Range("C" & i), Address:="", SubAddress:= _
"'" & Sheets("DATABASE").Name & "'!" & CrA, TextToDisplay:=Sheets("DATABASE").Range("D" & i).Value
NextC:
Resume NextD
NextD:
Next i
End Sub
But it only hyperlinks the first cell C4 in this case as the other cells have repeated values
答案1
得分: 0
这应该可以满足您的需求，无需运行时错误处理：
Sub AddHyperlinks2()
Dim rngMatch As Range, c As Range, wsApr As Worksheet, m, v
With Sheets("DATABASE")
Set rngMatch = .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
End With
Set wsApr = Sheets("APRILZ")
For Each c In wsApr.Range("C2:C" & wsApr.Cells(Rows.Count, "C").End(xlUp).Row).Cells
v = c.Value
If Len(v) > 0 Then
m = Application.Match(c.Value, rngMatch, 0) '无需Worksheetfunction = 无运行时错误
If Not IsError(m) Then '测试匹配
wsApr.Hyperlinks.Add Anchor:=c, Address:="", _
SubAddress:=rngMatch.Cells(m).Address(True, True, external:=True), _
TextToDisplay:=c.Value
End If
End If '任何单元格值
Next c
End Sub
英文:
This should do what you need without the need for run-time error handling:
Sub AddHyperlinks2()
Dim rngMatch As Range, c As Range, wsApr As Worksheet, m, v
With Sheets("DATABASE")
Set rngMatch = .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).row)
End With
Set wsApr = Sheets("APRILZ")
For Each c In wsApr.Range("C2:C" & wsApr.Cells(Rows.Count, "C").End(xlUp).row).Cells
v = c.Value
If Len(v) > 0 Then
m = Application.Match(c.Value, rngMatch, 0) 'no Worksheetfunction = no run-time error
If Not IsError(m) Then 'test for a match
wsApr.Hyperlinks.Add Anchor:=c, Address:="", _
SubAddress:=rngMatch.Cells(m).Address(True, True, external:=True), _
TextToDisplay:=c.Value
End If
End If 'any cell value
Next c
End Sub
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论