Excel VBA代码 - OLEDB连接

Question

我正在尝试使用下面的代码从一个excel文件获取数据，当它通过GetData宏时，它会在rsData.Open命令之后自动退出，因此它永远不会从关闭的工作簿中删除数据进入开放的工作簿。

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, _
                   Header As Boolean, UseHeaderRow As Boolean)

    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

    On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
                 vbExclamation, "Error"
    On Error GoTo 0

End Sub

Sub Update_DW_BaseCase()

    Application.Calculation = xlCalculationSemiautomatic
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    On Error Resume Next

    folder = Application.ActiveWorkbook.Path & "\"
    dw_file_name = ActiveWorkbook.Name
    model = Dir(folder & "*Base Case.xls*")

    irow = 2
    irow_descriptives = 2
    error_string = ""

    Do While Len(model) > 0

        GetData model, "Data Dump", "A7:EL85", Sheets("DATA").Range("A" & irow), False, False
        irow = Sheets("DATA").Range("A2").End(xlDown).Row + 1

        GetData model, "Data Dump", "B3:AE3", Sheets("Descriptives").Range("A" & _
                                               irow_descriptives), False, False
        irow_descriptives = irow_descriptives + 1

        model = Dir

    Loop

    Application.Calculation = xlCalculationSemiautomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True

End Sub