VBA遍历文件夹提取Excel多连接属性仅输出单条命令文本求助

原代码无法输出一一匹配的连接属性，核心问题如下：

• 输出行分配逻辑错误：仅为每个Excel文件预留1行输出位置，所有连接属性通过换行符拼接在同一单元格内，无法实现单条连接对应单条记录的匹配效果
• 变量未重置：存储连接名、连接串、命令文本的临时变量在处理新文件前未清空，会残留上一个文件的连接数据
• 连接类型兼容不足：默认所有连接均为OLEDB类型，遇到ODBC、Power Query、Web查询等其他连接类型时取值失败，全局错误捕获会直接跳过取值逻辑导致属性为空
• 细节逻辑bug：拼接连接名的换行判断条件笔误，误引用命令文本长度作为判断依据导致格式错乱；文件筛选常量定义为过程局部变量，跨过程调用时取值异常；打开文件时未禁用链接更新弹窗，会中断代码自动运行

Private oFSO As Object ' 文件系统对象
Private oRng As Range, N As Long ' 结果输出起始单元格、已扫描文件计数器
Private FILE_FILTER As String ' Excel文件筛选规则

Sub Main()
    Dim sRootFDR As String ' 扫描根目录
    Dim FldrPicker As FileDialog
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    ' 弹窗选择目标文件夹
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
        .Title = "选择目标扫描文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo ResetSettings
        sRootFDR = .SelectedItems(1) & "\"
    End With

    ' 定义扫描规则
    FILE_FILTER = "*.xl*"
   
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    N = 0
    ' 初始化结果输出表
    With ThisWorkbook.Worksheets("Sheet1")
        .UsedRange.ClearContents
        .Range("A1:E1").Value = Array("文件路径", "文件总连接数", "连接名称", "连接字符串", "命令文本")
        .Range("A1:E1").Font.Bold = True
        Set oRng = .Range("A2")
    End With
    
    ' 开始递归扫描
    ListFolder sRootFDR
    
    ' 扫描完成后格式调整
    ThisWorkbook.Worksheets("Sheet1").UsedRange.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set oRng = Nothing
    Set oFSO = Nothing
    MsgBox N & " 个Excel文件扫描完成。"
   
ResetSettings:
    ' 重置Excel设置
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Sub ListFolder(ByVal sFDR As String)
    Dim oFDR As Object
    ' 扫描当前目录下的文件
    ListFiles sFDR, FILE_FILTER
    ' 递归扫描子文件夹
    For Each oFDR In oFSO.GetFolder(sFDR).SubFolders
        ListFolder oFDR.Path & "\"
    Next
End Sub

Private Sub ListFiles(ByVal sFDR As String, ByVal sFilter As String)
    Dim sItem As String
    sItem = Dir(sFDR & sFilter)
    Do Until sItem = ""
        ' 跳过当前宏所在工作簿，避免自我扫描
        If sFDR & sItem <> ThisWorkbook.FullName Then
            N = N + 1
            CheckFileConnections sFDR & sItem
        End If
        sItem = Dir
    Loop
End Sub

Private Sub CheckFileConnections(ByVal sFile As String)
    Dim oWB As Workbook, oConn As WorkbookConnection
    Dim connCount As Long
    Dim sConnStr As String, sCmdText As String
    
    Application.StatusBar = "正在处理: " & sFile
    ' 只读打开文件，禁用链接更新避免弹窗中断
    Set oWB = Workbooks.Open(Filename:=sFile, ReadOnly:=True, UpdateLinks:=xlUpdateLinksNever)
    
    With oWB
        connCount = .Connections.Count
        ' 无连接的文件输出1行记录
        If connCount = 0 Then
            oRng.Value = sFile
            oRng.Offset(0, 1).Value = 0
            oRng.Offset(0, 2).Value = "无外部连接"
            Set oRng = oRng.Offset(1)
        Else
            ' 遍历所有连接，每个连接单独占1行，保证属性一一对应
            For Each oConn In .Connections
                ' 写入文件基础信息
                oRng.Value = sFile
                oRng.Offset(0, 1).Value = connCount
                oRng.Offset(0, 2).Value = oConn.Name
                
                ' 按连接类型读取对应属性，缩小错误捕获范围
                On Error Resume Next
                Select Case oConn.Type
                    Case xlConnectionTypeOLEDB
                        sConnStr = oConn.OLEDBConnection.Connection
                        sCmdText = oConn.OLEDBConnection.CommandText
                    Case xlConnectionTypeODBC
                        sConnStr = oConn.ODBCConnection.Connection
                        sCmdText = oConn.ODBCConnection.CommandText
                    Case Else
                        sConnStr = "非OLEDB/ODBC类型连接，类型编码：" & oConn.Type
                        sCmdText = ""
                End Select
                On Error GoTo 0
                
                ' 写入连接属性
                oRng.Offset(0, 3).Value = sConnStr
                oRng.Offset(0, 4).Value = sCmdText
                
                ' 移动到下一行输出位
                Set oRng = oRng.Offset(1)
                ' 重置临时变量避免残留
                sConnStr = ""
                sCmdText = ""
            Next oConn
        End If
    End With
    
    ' 不保存关闭文件
    oWB.Close SaveChanges:=False
    Set oWB = Nothing
    Application.StatusBar = False
End Sub

• 调整输出逻辑：每个外部连接单独占用1行，彻底解决属性拼接错位问题，文件包含13组连接时会对应输出13行匹配的属性记录
• 新增兼容逻辑：同时支持OLEDB、ODBC两类主流外部连接的属性读取，非这两类的连接会标注类型，不会出现空值
• 修复所有已知bug：新增自我扫描跳过逻辑、禁用打开文件时的弹窗、修正变量作用域问题、移除多余的重复列宽自适应操作提升运行速度
• 变量清理：每处理完一条连接就重置临时变量，避免历史数据残留

内容的提问来源于stack exchange，提问作者Shilpa Venkatesh