Question

我将ADO与下面的代码结合使用，以从关闭的文件中提取数据。

我工作得很好，但是我想知道是否有一种方法可以使用select语句中的命名范围代替Address。这样可以使宏更加动态。

是否有人知道在sourceRange的select语句中使用命名范围的方法（在目标文件和当前文件中，命名范围都可以使用，但高度或高度可以不同）。

 Sub getFromClosedFile
   Dim CN As Object, RS As Recordset

   sourceFile = Application.GetOpenFilename("Excel Files (*.xls*), *xls*", , "Select QIP file", "Select QIP", False)

   'GET RECORDSET FROM CLOSED FILE
   Set CN = ADO_OpenConnection(sourceFile, True)

   Set rngTarget = Sheets(sourceSheet).Range("A1") 'HERE I WOULD WANT TO USE A NAMED RANGE INSTEAD OF A1
   
   'GET RECORDSET
   Set RS = ADO_GetRecordsetFromOpenedConnection(CN, CStr(sourceSheet), sourceRange)

   ' COPY RECORDSET TO SHEET
   ADO_CopyRsToTargetRange RS, rngTarget, True, True ', Header, UseHeaderRow
        
   ' CLEAN UP VARIABLES - USE BYREF
   ADO_ClearRecordset RS
   ADO_ClearConnection CN
End sub

Public Function ADO_OpenConnection(sourceFilePath As String, _
                                    Optional Header As Boolean, Optional UseHeaderRow As Boolean) As Object
    
    Dim rsCon  As Object
    Dim sourceFileExtension As String, strProvider As String, strExcelVersion As String, strHdr As String, szConnect As String
    
    sourceFileExtension = Split(sourceFilePath, ".")(UBound(Split(sourceFilePath, ".")))
    
    'BY EXCEL VERSION
    If Val(Application.Version) < 12 Then
        strProvider = "Microsoft.Jet.OLEDB.4.0;"
        strExcelVersion = "Excel 8.0"
    Else
        strProvider = "Microsoft.ACE.OLEDB.12.0;"
        Select Case UCase(sourceFileExtension)
            Case "XLSM": strExcelVersion = "Excel 12.0 Macro"
            Case "XLSX": strExcelVersion = "Excel 12.0"
        End Select
    End If
    
    If Header = False Then
        strHdr = "HDR=NO"
    Else
        strHdr = "HDR=YES"
    End If
    
    szConnect = "Provider=" & strProvider & _
            "Data Source=" & sourceFilePath & ";" & _
            "Extended Properties=""" & strExcelVersion & ";" & strHdr & """;"
        
    'CREATE CONNECTION OBJECT
    Set rsCon = CreateObject("ADODB.Connection")
1:        rsCon.Open szConnect

    Set ADO_OpenConnection = rsCon
End Function

Public Function ADO_GetRecordsetFromOpenedConnection(rsCon As Object, sourceSheet As String, Optional sourceRange As String) As Recordset
    
    Dim szSQL As String, rsData As Recordset
    
    'COMBINE SQL STRING TO SELECT SPECIFIC SHEET/RANGE
    szSQL = "Select * from [" & sourceSheet & "$" & sourceRange & "]"
    
    'CREATE CONNECTION OBJECTS
    Set rsData = CreateObject("ADODB.Recordset")
2:        rsData.Open szSQL, rsCon, 0, 1, 1

    Set ADO_GetRecordsetFromOpenedConnection = rsData
End Function

Sub ADO_CopyRsToTargetRange(ByRef rsData As Recordset, ByRef TargetRange As Range, Optional Header As Boolean, Optional UseHeaderRow As Boolean)
    
    Dim lCount As Long, RS As Recordset
'https://www.devguru.com/content/technologies/ado/recordset-filter.html
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).value = rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If

    Else
        'MsgBox "No records returned from : " & sourceFile, vbCritical
    End If
End Sub

Sub ADO_ClearConnection(ByRef rsCon As Object)
    rsCon.Close
    Set rsCon = Nothing
End Sub

Sub ADO_ClearRecordset(ByRef rsData As Object)
    rsData.Close
    Set rsData = Nothing
End Sub

在ADO中使用命名范围，可以吗？

0 个答案: