vba 自动超链接

先做文件夹扫描然后根据e列内容，对u列进行超链接填空。
=HYPERLINK("#"&B2&"!A1",B2)。这个函数也可以用来做超链接

Public Function FileFolderExists(strFullPath As String) As Boolean

On Error GoTo EarlyExit
  If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
  On Error GoTo 0

End Function

Sub 遍历文件夹()
'Columns(1).Delete
On Error Resume Next
Dim f As String
Dim file() As String
Dim split_str() As String
Dim i, k, x
x = 1
i = 1: k = 1
ReDim file(1 To i)
pth = ThisWorkbook.Path & "\"
pth = pth + "扫黑除恶专项斗争工作档案\"
file(1) = pth 'InputBox("请输入要查找的文件夹：") & "\"
If Not FileFolderExists(file(1)) Then
    MsgBox "指定的文件夹不存在！"
    Exit Sub
End If

'---------遍历文件夹----------
Do Until i > k
    f = Dir(file(i), vbDirectory)
        Do Until f = ""
            If f <> "." And f <> ".." Then
                k = k + 1
                ReDim Preserve file(1 To k)
                file(k) = file(i) & f & "\"
            End If
            f = Dir
        Loop
    i = i + 1
Loop
'---------------根据B列找然后在F列输入 ----超链接到文件夹-----------
For sheeti = 1 To Sheets.Count
    For x = 3 To Sheets(sheeti).Range("E65535").End(xlUp).Row
        For i = 1 To 251
           If (Sheets(sheeti).Range("B" & x) = "") Then
           GoTo outFor
            End If
           split_str() = Split(file(i), "\")
           Length = UBound(split_str) - LBound(split_str)
'InStr(file(i), Sheets(sheeti).Range("E" & x)) <> 0
           If (Sheets(sheeti).Range("B" & x) = split_str(Length - 1)) Then
           Sheets(sheeti).Range("F" & x).Hyperlinks.Add Anchor:=Sheets(sheeti).Range("F" & x), Address:= _
            file(i), TextToDisplay:=Sheets(sheeti).Range("B" & x).Text
            
          End If
        Next
          
    Next
outFor:
Next

Exit Sub
For sheeti = 1 To Sheets.Count
    For i = 1 To k
        If (Sheets(sheeti).Range("E" & x + 2) = "") Then
           GoTo outFor1
        End If
        
           If (InStr(file(i), Sheets(sheeti).Range("E" & x + 2)) <> 0) Then
           Sheets(sheeti).Range("U" & x + 2).Hyperlinks.Add Anchor:=Sheets(sheeti).Range("U" & x + 2), Address:= _
            file(i), TextToDisplay:=Sheets(sheeti).Range("E" & x + 2).Text
            x = x + 1
          End If
    Next
outFor1:
x = 1
Next


'----------在每个文件夹里面找文件-------
For i = 1 To k
    f = Dir(file(i) & "*.*")
    Do Until f = ""
       'Range("a" & x) = f
       Range("U" & x + 3).Hyperlinks.Add Anchor:=Range("U" & x + 3), Address:= _
        file(i), TextToDisplay:=Range("E" & x + 3).Text
        x = x + 1
        f = Dir
    Loop
Next


End Sub

遍历文件夹和子文件夹，找到对应的jpg文件，重命名到新的文件夹里面去

Sub 遍历文件夹()
'Columns(1).Delete
On Error Resume Next
Dim f As String
Dim file() As String
Dim split_str() As String
Dim i, k, x
x = 1
i = 1: k = 1
ReDim file(1 To i)
pth = ThisWorkbook.Path & "\"
pth = "D:\[173M]\"
file(1) = pth 'InputBox("请输入要查找的文件夹：") & "\"
If Not FileFolderExists(file(1)) Then
    MsgBox "指定的文件夹不存在！"
    Exit Sub
End If

'---------遍历文件夹----------
Do Until i > k
    f = Dir(file(i), vbDirectory)
        Do Until f = ""
            If f <> "." And f <> ".." Then
                k = k + 1
                ReDim Preserve file(1 To k)
                file(k) = file(i) & f & "\"
            End If
            f = Dir
        Loop
    i = i + 1
Loop
ik = 1
For ij = 1 To i
If InStr(file(ij), ".jpg") Or InStr(file(ij), ".jpeg") Then

Cells(ik, 1) = Mid(file(ij), InStrRev(file(ij), "\", InStrRev(file(ij), "\", Len(file(ij)) - 1) - 1))
Cells(ik, 1) = Replace(Cells(ik, 1), "\", "")
dirfile = "D:\test\" + Cells(ik, 1)
FileCopy Left(file(ij), Len(file(ij)) - 1), dirfile
ik = ik + 1
End If