宏vba代码以查找具有连接的工作簿

我正在尝试扫描文件夹和子文件夹，查找其中包含连接字符串和sql命令的工作簿，但我不知道如何执行此操作。下面的代码是我所拥有的（到目前为止），我被卡住了。我对宏非常陌生，所以我不知道我是否做对了。基本上，我希望在新工作簿中使用的列标题是文件路径、连接字符串和SQL命令。可以在数据->连接下找到连接字符串和SQL命令。现在，下面的代码没有编写任何内容，因此当您运行它时，它将打开一个新工作簿，但其中没有任何内容。请帮帮我(

Sub readdatafromlworkbooksinfolder（）
Dim FolderName作为字符串“文件夹名称”
将wbName设置为字符串“文件夹和工作簿的全名”。
变暗r为“长”行数计数器
不需要“作为变量的尺寸C值”
Dim wbList（）作为excel工作簿的字符串列表
Dim wbCount为整数的excel工作簿数
尺寸i，j作为整数计数器
'启动文件夹
FolderName=“C:\Users\lchua\”
'在foldername中创建工作簿列表并将其放入电子表格中
wbCount=0
wbName=Dir（FolderName&“\”&“*.xls”）“我不知道如何在子目录中执行此操作：（
当wbName“”创建文件和目录列表时
wbCount=wbCount+1
重拨保留wbList（1到wbCount）
wbList（wbCount）=文件夹名和wbName
wbName=Dir
温德
如果wbCount=0，则退出Sub
r=0
“工作簿.添加”创建一个新工作簿以将数据放入其中
Application.ScreenUpdate=False“关闭屏幕更新
对于i=1到wbCount
设置wb=Workbooks.Open（wbList（i），True，True）
如果wb.Connections.Count>0，则
numconnections=wb.Connections.Count
对于j=1到numconnections
'将信息读入电子表格
Query=ActiveWorkbook.Connections（j）.ODBCConnection.CommandText
ConnectionString=ActiveWorkbook.Connections（j）.ODBCConnection.Connection
下一个j
如果结束
wb.Close False“关闭源工作簿而不保存任何更改”
设置wb=无可用内存
'r=r+1
'cValue=GetInfoFromClosedFile（文件夹名称，wbList（i），“Sheet1”，“A1”）
'单元格（r，1）。公式=wbList（i）
'单元格（r，2）。公式=C值
接下来我
端接头

我相信在这之后你会爱上VBA

---

根据您想要实现的目标，将有4个部分（子部分）：

列出工作簿（如果有）的所有连接和命令文本的子项

获取文件夹中所有Excel文件名称的子文件

要在上面递归到每个子文件夹的子文件夹

要在上面启动的主Sub

考虑我下面的代码：

Private Const FILE_FILTER = "*.xl*"
Private Const sRootFDR = "C:\Users\lchua\" ' Root Folder

Private oFSO As Object ' For FileSystemObject
Private oRng As Range, N As Long ' Range object and Counter

Sub Main()
    Application.ScreenUpdating = False
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    N = 0
    With ThisWorkbook.Worksheets("Sheet1")
        .UsedRange.ClearContents ' Remove previous contents
        .Range("A1:D1").Value = Array("Filename", "Connections", "Connection String", "Command Text")
        Set oRng = .Range("A2") ' Initial Cell to start storing results
    End With
    ListFolder sRootFDR
    Application.ScreenUpdating = True
    Set oRng = Nothing
    Set oFSO = Nothing
    MsgBox N & " Excel files has been checked for connections."
End Sub

Private Sub ListFolder(ByVal sFDR As String)
    Dim oFDR As Object
    ' List the files of this Directory
    ListFiles sFDR, FILE_FILTER
    ' Recurse into each Sub Folder
    For Each oFDR In oFSO.GetFolder(sFDR).SubFolders
        ListFolder oFDR.Path & "\" ' Need '\' to ensure the file filter works
    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 = ""
        N = N + 1 ' Increment Counter
        oRng.Value = sFDR & sItem
        CheckFileConnections oRng.Value ' Call Sub to Check the Connection settings
        Set oRng = oRng.Offset(1) ' Move Range object to next cell below
        sItem = Dir
    Loop
End Sub

Private Sub CheckFileConnections(ByVal sFile As String)
    Dim oWB As Workbook, oConn As WorkbookConnection
    Dim sConn As String, sCMD As String
    Application.StatusBar = "Opening workbook: " & sFile
    Set oWB = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
    With oWB
        oRng.Offset(0, 1).Value = .Connections.Count ' 1 column to right (B)
        For Each oConn In .Connections
            If Len(sConn) > 0 Then sConn = sConn & vbLf
            If Len(sCMD) > 0 Then sCMD = sCMD & vbLf
            sConn = sConn & oConn.ODBCConnection.Connection
            sCMD = sCMD & oConn.ODBCConnection.CommandText
        Next
        oRng.Offset(0, 2).Value = sConn ' 2 columns to right (C)
        oRng.Offset(0, 3).Value = sCMD ' 3 columns to right (D)
    End With
    oWB.Close False ' Close without saving
    Set oWB = Nothing
    Application.StatusBar = False
End Sub

“我的测试文件夹”不包含任何带有连接的工作簿，因此输出为：

---

您应该根据工作表更改这些信息的存储位置。您可能希望注释掉

MsgBox

。希望它不会在与连接相关的情况下出错。

对于您想要实现的功能，最好使用

FileSystemObject

（FSO）或者混合使用FSO和Dir，而不是

Dir

仅用于递归文件搜索。非常感谢您的帮助！但是对于命令文本，它向我显示了另一个连接字符串，而不是sql查询。我一直在试图找出原因。代码看起来是正确的，因为它说。CommandTextThank非常感谢您，Patrick。我将带上time学习和理解你的代码。我对vba很陌生。关于如何学好它有什么建议吗？或者你知道一本好的vba书吗？我没有任何书可以参考，当我想检查对象时，我会去MSDN。你也可以在vba中加入很多其他东西，比如.NET SystemCollections、WshShell、对象等。所以，玩得开心！

Private Const FILE_FILTER = "*.xl*"
Private Const sRootFDR = "C:\Users\lchua\" ' Root Folder

Private oFSO As Object ' For FileSystemObject
Private oRng As Range, N As Long ' Range object and Counter

Sub Main()
    Application.ScreenUpdating = False
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    N = 0
    With ThisWorkbook.Worksheets("Sheet1")
        .UsedRange.ClearContents ' Remove previous contents
        .Range("A1:D1").Value = Array("Filename", "Connections", "Connection String", "Command Text")
        Set oRng = .Range("A2") ' Initial Cell to start storing results
    End With
    ListFolder sRootFDR
    Application.ScreenUpdating = True
    Set oRng = Nothing
    Set oFSO = Nothing
    MsgBox N & " Excel files has been checked for connections."
End Sub

Private Sub ListFolder(ByVal sFDR As String)
    Dim oFDR As Object
    ' List the files of this Directory
    ListFiles sFDR, FILE_FILTER
    ' Recurse into each Sub Folder
    For Each oFDR In oFSO.GetFolder(sFDR).SubFolders
        ListFolder oFDR.Path & "\" ' Need '\' to ensure the file filter works
    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 = ""
        N = N + 1 ' Increment Counter
        oRng.Value = sFDR & sItem
        CheckFileConnections oRng.Value ' Call Sub to Check the Connection settings
        Set oRng = oRng.Offset(1) ' Move Range object to next cell below
        sItem = Dir
    Loop
End Sub

Private Sub CheckFileConnections(ByVal sFile As String)
    Dim oWB As Workbook, oConn As WorkbookConnection
    Dim sConn As String, sCMD As String
    Application.StatusBar = "Opening workbook: " & sFile
    Set oWB = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
    With oWB
        oRng.Offset(0, 1).Value = .Connections.Count ' 1 column to right (B)
        For Each oConn In .Connections
            If Len(sConn) > 0 Then sConn = sConn & vbLf
            If Len(sCMD) > 0 Then sCMD = sCMD & vbLf
            sConn = sConn & oConn.ODBCConnection.Connection
            sCMD = sCMD & oConn.ODBCConnection.CommandText
        Next
        oRng.Offset(0, 2).Value = sConn ' 2 columns to right (C)
        oRng.Offset(0, 3).Value = sCMD ' 3 columns to right (D)
    End With
    oWB.Close False ' Close without saving
    Set oWB = Nothing
    Application.StatusBar = False
End Sub