删除指定文件夹下的所有文件外部链接

最新推荐文章于 2022-04-24 20:44:03 发布

gf1321111

最新推荐文章于 2022-04-24 20:44:03 发布

阅读量481

点赞数 1

分类专栏： EXCEL VBA

本文链接：https://blog.csdn.net/gf1321111/article/details/112035330

版权

VBA Excel链接文件清理自动化脚本路径管理

关键词由CSDN通过智能技术生成

EXCEL 同时被 2 个专栏收录

5 篇文章 0 订阅

订阅专栏

VBA

1 篇文章 0 订阅

订阅专栏

删除指定文件夹下的所有文件外部链接。

改了两天，终于成功了！
excel附件地址：https://download.csdn.net/download/gf1321111/14001265

Sub BreakLinkANDDelNames()
Dim aLinks As Variant
Dim j, I As Integer
Dim MyName, Dic, Did, T, TT, MyFileName

On Error Resume Next
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False

 T = Time
    Set Dic = CreateObject("Scripting.Dictionary")    '创建bai一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add ("C:\Users\Administrator\Desktop\微众融资安徽\"), ""
    I = 0
    Do While I < Dic.Count                            '这个返回的是文件夹的目录
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(I), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(I) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        I = I + 1
    Loop
    
     Did.Add ("文件名"), ""
     For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.xls*")                '遍历每个文件夹，Ke就是文件夹的路径
        Do While MyFileName <> ""
             With GetObject(Ke & "\" & MyFileName)
                aLinks = .LinkSources(Type:=xlLinkTypeExcelLinks)
                If Not IsEmpty(aLinks) Then
                    For j = 1 To UBound(aLinks)
                        .BreakLink Name:=aLinks(j), Type:=xlLinkTypeExcelLinks
                    Next j
                 End If
                 Application.Windows(.Name).Visible = True  '将表取消隐藏。
                     If .Name <> ThisWorkbook.Name Then '注意这里如果不加IF判断，如果先打开的这个表，那么首先就会先关闭，后面的就不会运行了。
                         .Close (True)    '保存改动
                     End If
            End With
        Did.Add (Ke & MyFileName), ""
        MyFileName = Dir
        Loop
    Next
    ThisWorkbook.Sheets("汇总").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
    ThisWorkbook.Sheets("汇总").[A1].Activate

    TT = Time - T
    MsgBox Minute(TT) & "分" & Second(TT) & "秒"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
End Sub