批量替换400个文件中不同的超链接

Sub ChangeHyperlinks() Dim ws As Worksheet Dim hlink As Hyperlink For Each ws In ThisWorkbook.Worksheets For Each hlink In ws.Hyperlinks If hlink.Address = "a" Then hlink.Address = "d" ElseIf hlink.Address = "b" Then hlink.Address = "e" ElseIf hlink.Address = "c" Then hlink.Address = "f" End If Next hlink Next ws End Sub 这个可以但是我有四百个文件需要替换他们都是一个比如 https://example.com/a/a.pdf https://example.com/b/b.pdf https://example.com/c/c.pdf 只不过我要把路径/a /b /c 替换成 /d /e /f 这样，我想要第一步先获取到这四百个文件的超链接然后输出到一个 Excel的比如列中，比如第一列是文件名，第二列是旧的超链接，第三列是新的超链接每一行是一个文件的信息然后等我手动把第三列填充完毕了再开始批量根据第二列替换成第三列的值

以下是一种可以实现你需求的方法：

一、获取四百个文件的超链接信息并输出到 Excel

使用 VBA 可以遍历指定文件夹中的 Excel 文件，并提取其中的超链接信息。假设这些文件都在一个特定的文件夹中，比如 “D:\ExcelFiles”。以下是代码示例：复制

Sub GetHyperlinksFromFiles()
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim hlink As Hyperlink
    Dim outputRow As Long
    Dim targetFolder As String
    
    targetFolder = "D:\ExcelFiles" '修改为你的实际文件夹路径
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(targetFolder)
    
    Set ws = ThisWorkbook.Worksheets(1) '假设输出到当前工作簿的第一个工作表
    
    outputRow = 1
    
    For Each file In folder.Files
        If Right(file.Name, 5) = ".xlsx" Or Right(file.Name, 4) = ".xls" Then '只处理 Excel 文件
            Set wb = Workbooks.Open(file.Path)
            For Each ws In wb.Worksheets
                For Each hlink In ws.Hyperlinks
                    ws.Cells(outputRow, 1).Value = file.Name '文件名
                    ws.Cells(outputRow, 2).Value = hlink.Address '旧超链接
                    outputRow = outputRow + 1
                Next hlink
            Next ws
            wb.Close False
        End If
    Next file
End Sub

运行这段代码后，它会将指定文件夹中的所有 Excel 文件中的超链接信息提取出来，并输出到当前工作簿的第一个工作表中，第一列是文件名，第二列是旧的超链接。

二、手动填充第三列新的超链接值

你可以在生成的 Excel 表格中手动填充第三列新的超链接值。

三、批量根据第二列替换成第三列的值

使用以下 VBA 代码来实现批量替换：

Sub ReplaceHyperlinks()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    Set ws = ThisWorkbook.Worksheets(1) '假设在当前工作簿的第一个工作表中操作
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To lastRow
        Dim oldLink As String
        Dim newLink As String
        oldLink = ws.Cells(i, 2).Value
        newLink = ws.Cells(i, 3).Value
        If oldLink <> "" And newLink <> "" Then
            ReplaceHyperlinkInWorkbook oldLink, newLink
        End If
    Next i
End Sub

Sub ReplaceHyperlinkInWorkbook(oldLink As String, newLink As String)
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim hlink As Hyperlink
    
    For Each wb In Workbooks
        For Each ws In wb.Worksheets
            For Each hlink In ws.Hyperlinks
                If hlink.Address = oldLink Then
                    hlink.Address = newLink
                End If
            Next hlink
        Next ws
    Next wb
End Sub

这段代码会遍历当前打开的所有工作簿，将旧超链接替换为新超链接。在运行此代码之前，请确保已经手动填充好了第三列新超链接的值。