如何解决在ADO中使用命名范围,可以吗?
我将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,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
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。