VBA运行时错误3001：参数类型错误或超出范围求助

问题概述 #

运行指定VBA代码时触发运行时错误3001，提示“Arguments are of the wrong type or out of acceptable range”，错误定位在以下代码行：

rs.Open "SELECT * FROM [" & sheetName & "]", conn, adOpenStatic, adLockReadOnly

代码核心逻辑：遍历指定文件夹内以"10"开头的XLSX文件，将其中的Sale、AP、AR、Purchase工作表复制到新工作簿并保存。

错误原因分析 #

1. Late Binding下常量未定义：代码用CreateObject创建ADODB对象（Late Binding），但直接使用adOpenStatic、adLockReadOnly等常量名——这类常量仅在Early Binding（引用ADO库）时可用，Late Binding下需用对应数值代替。
2. 连接字符串语法错误：原连接字符串末尾多了冗余分号，且Extended Properties格式适配性不足。
3. 工作表存在性检查逻辑缺陷：原SheetExists函数通过全表查询判断工作表存在性，易因数据格式问题触发错误，导致误判或占用连接资源。
4. 连接对象复用异常：循环中复用同一个连接对象，若前一次未正确关闭，会导致后续连接状态异常。

解决方案 #

1. 替换ADODB常量为数值 #

Late Binding下，将adOpenStatic（值为3）和adLockReadOnly（值为1）替换为对应数值：

rs.Open "SELECT * FROM [" & sheetName & "]", conn, 3, 1

2. 修正连接字符串 #

移除冗余分号，调整Extended Properties适配XLSX格式：

conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
          "Data Source=" & File_Path & ";" & _
          "Extended Properties=""Excel 12.0 Xml;HDR=Yes;IMEX=1"""

3. 优化工作表存在性检查 #

改用OpenSchema方法查询表（工作表）信息，更高效准确：

Function SheetExists(ByVal conn As Object, ByVal sheetName As String) As Boolean
    Dim rsSchema As Object
    Set rsSchema = conn.OpenSchema(20) ' adSchemaTables 对应的数值
    Do While Not rsSchema.EOF
        If rsSchema!TABLE_NAME = sheetName Then
            SheetExists = True
            Exit Do
        End If
        rsSchema.MoveNext
    Loop
    rsSchema.Close
End Function

4. 调整连接对象生命周期 #

将连接对象的创建移至循环内部，确保每个文件对应独立连接，避免状态异常：

While fileName <> ""
    If Left(fileName, 2) = "10" Then
        File_Path = path_Input & fileName
        ' 为每个文件创建新连接
        Set conn = CreateObject("ADODB.Connection")
        ' 打开连接、处理工作表...
        ' 处理完毕后关闭并释放连接
        conn.Close
        Set conn = Nothing
    End If
    fileName = Dir
Wend

5. 验证工作表名称准确性 #

确认源文件中工作表名称与数组内的Sale$、AP$、AR$、Purchase$完全一致（注意名称后需带$，若名称含空格需写成[Sheet Name$]格式）。

修正后的完整代码 #

Sub CopySheetsToNewWorkbookWithADODB()
    Dim path_Input As String
    Dim path_Output As String
    Dim File_Path As String
    Dim conn As Object
    Dim rs As Object
    
    path_Input = "C:\Users\aa\Desktop\convert file\"
    path_Output = "C:\Users\aa\Desktop\convert file\"
    
    ' Loop through all files in a folder
    Dim fileName As String
    fileName = Dir(path_Input & "*.xlsx")
    
    While fileName <> ""
        ' Check if the filename starts with "10"
        If Left(fileName, 2) = "10" Then
            ' Build the full file path
            File_Path = path_Input & fileName
            
            ' Create a new connection for each file
            Set conn = CreateObject("ADODB.Connection")
            
            ' Create a connection to the Excel file
            conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & File_Path & ";" & _
                "Extended Properties=""Excel 12.0 Xml;HDR=Yes;IMEX=1"""
            
            ' Create a new workbook
            Dim destWb As Workbook
            Set destWb = Workbooks.Add
            
            ' Loop through the sheets you want to copy
            Dim sheetNames As Variant
            sheetNames = Array("Sale$", "AP$", "AR$", "Purchase$")
            
            For Each sheetName In sheetNames
                ' Check if the sheet exists in the Excel file
                If SheetExists(conn, sheetName) Then
                    ' Create a recordset for the sheet
                    Set rs = CreateObject("ADODB.Recordset")
                    ' Use numeric values for Late Binding constants
                    rs.Open "SELECT * FROM [" & sheetName & "]", conn, 3, 1
                    
                    ' Copy data from the recordset to the new workbook
                    Dim destWs As Worksheet
                    Set destWs = destWb.Sheets.Add
                    destWs.Cells(1, 1).CopyFromRecordset rs
                    
                    ' Close the recordset
                    rs.Close
                    Set rs = Nothing
                End If
            Next sheetName
            
            ' Save the new workbook
            File_Path = path_Output & Left(fileName, 4) & "_Output.xlsx"
            destWb.SaveAs fileName:=File_Path, FileFormat:=xlWorkbookDefault
            destWb.Close SaveChanges:=False
            
            ' Close the connection
            conn.Close
            Set conn = Nothing
        End If
        
        ' Get the next filename
        fileName = Dir
    Wend
    
    MsgBox "Convert Complete"
End Sub

Function SheetExists(ByVal conn As Object, ByVal sheetName As String) As Boolean
    Dim rsSchema As Object
    Set rsSchema = conn.OpenSchema(20) ' adSchemaTables
    Do While Not rsSchema.EOF
        If rsSchema!TABLE_NAME = sheetName Then
            SheetExists = True
            Exit Do
        End If
        rsSchema.MoveNext
    Loop
    rsSchema.Close
    Set rsSchema = Nothing
End Function

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