☰

宏从另一张表复制超链接

tag-icon • tag-icon vba microsoft-excel-2013
宏从另一张表复制超链接

我在这个网站上找到了一个宏，可以将通过功能区插入的超链接复制到另一张表的不同列。但是，该宏只在第一行起作用。

我添加了Do直到因为i = 7 to 1007没有让它转到next。现在它超时了，仍然不起作用。我只想为此使用一个函数，但它给 Mac 上的其他用户带来了问题，所以我试图绕过 Mac 的困难。

我应该说明一下第一张表上的某些行是空白的。

Sub SwapIt()
    Dim i As Integer
    i = 7
    Do Until i > 1007
        Dim newLink As String
        If Worksheets("Directory").Active = True Then
        newLink = Worksheets("Modeling Tracker").Range("S" & i).Hyperlinks(1).Address ' Get the old horrible link :)
        Worksheets("Directory").Range("B" & i).Hyperlinks.Add anchor:=Worksheets("Directory").Range("B" & i), Address:=Worksheets("Directory").Range("B" & i) 'turns it to a link
        Worksheets("Directory").Range("B" & i).Hyperlinks(1).Address = newLink 'replace with the new link.
        i = i + 1
        End If
    Loop

End Sub

任何帮助都将不胜感激。这让我抓狂了。

耶！我找到了。只是缺少一个范围。

Sub SwapIt()
Dim i As Integer
For i = 7 To 1007
If Worksheets("Modeling Tracker").Range("S" & i).Value > "" Then
    Dim newLink As String
    If Worksheets("Modeling Tracker").Range("S" & i).Hyperlinks.Count = 1 Then
    newLink = Worksheets("Modeling Tracker").Range("S" & i).Hyperlinks(1).Address 
    Worksheets("Directory").Range("B" & i).Hyperlinks.Add Anchor:=Worksheets("Directory").Range("B" & i), Address:=Worksheets("Directory").Range("B" & i) 'turns it to a link
    Worksheets("Directory").Range("B" & i).Hyperlinks(1).Address = newLink '' replace with the new link.
    End If
End If
Next i
End Sub

答案1

这是修复后的代码。我还添加了一个“如果这样，如果原始链接单元格为空白，它将删除新工作表中的超链接，因为当您重新排序信息时，另一张工作表上与空白相对应的单元格仍然具有上次应用宏时的旧超链接。

Sub UpdateLinks_Click()
' Copy the hyperlink from Modeling Tracker Sheet and apply it to the Directory

Dim i As Integer

For i = 7 To 1007

If Worksheets("Modeling Tracker").Range("S" & i).Value > "" Then
Dim newLink As String
    If Worksheets("Modeling Tracker").Range("S" & i).Hyperlinks.Count = 1 Then
    newLink = Worksheets("Modeling Tracker").Range("S" & i).Hyperlinks(1).Address ' Get the link from the Modeling Tracker
    Worksheets("Directory").Range("B" & i).Hyperlinks.Add Anchor:=Worksheets("Directory").Range("B" & i), Address:=Worksheets("Directory").Range("B" & i) 'turns it to a link
    Worksheets("Directory").Range("B" & i).Hyperlinks(1).Address = newLink 'replace it with newLink
    End If
End If
If Worksheets("Modeling Tracker").Range("S" & i).Value = "" Then
Worksheets("Directory").Range("B" & i).Hyperlinks.Delete
End If
Next i
Worksheets("Directory").Range("B7:B1007").Font.Color = vbBlack ' this to is avoid the auto hyperlink format
Worksheets("Directory").Range("B7:B1007").Font.Underline = False ' this is to avoid the auto-hyperlink format
End Sub

相关内容