'在第8列中不为空的清空下，从第一列中的超链接中，去目录，放在对应第二列中

Sub ChangeDocumentLinkToFolderLink()
On Error Resume Next
Dim a As String
With ActiveSheet
    rowmax = .Cells(1048576, 5).End(xlUp).Row
    For i = 2 To rowmax
        If .Cells(i, 8) <> "" Then
            a = ChangeDocumentLinkToFolderLink2(.Cells(i, 1).Hyperlinks(1).Address)
            .Cells(i, 2).Hyperlinks.add .Cells(i, 2), a
        End If
    Next
End With
End Sub
'取目录

Function ChangeDocumentLinkToFolderLink2(add As String)
For i = Len(add) To 1 Step -1
    If Mid(add, i, 1) = "/" Then
        ChangeDocumentLinkToFolderLink2 = Left(add, i)
        Exit For
    End If
Next
End Function
'浏览器中打开目录地址

Sub opernHyperlinks()
On Error Resume Next
Dim a As String
With ActiveSheet
    rowmax = .Cells(1048576, 5).End(xlUp).Row
    For i = 2 To rowmax
        If .Cells(i, 2).Hyperlinks.Count > 0 Then
            .Cells(i, 2).Hyperlinks(1).Follow NewWindow:=True
'            IE.Navigate .Cells(i, 2).Hyperlinks(1).Address
        End If
    Next
End With
End Sub