在Excel中使用VBA关闭的工作簿（ADO）导入数据
如果要从封闭的工作簿中导入大量数据，则可以使用ADO和下面的宏来完成。
如果要从已关闭工作簿中的第一个工作表之外的其他工作表中检索数据，则必须引用用户定义的命名范围。下面的宏可以这样使用（在Excel 2000或更高版本中）：
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "A1:B21", ActiveCell, False
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "MyDataRange", Range ("B3"), True
Sub GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String, _
TargetRange As Range, IncludeFieldNames As Boolean)
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
' this will return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
' this will return data from any worksheet in SourceFile
' SourceRange must include the range headers
'
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
Dim TargetCell As Range, i As Integer
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"ReadOnly=1;DBQ=" & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ' open the database connection
Set rs = dbConnection.Execute("[" & SourceRange & "]")
Set TargetCell = TargetRange.Cells(1, 1)
If IncludeFieldNames Then
For i = 0 To rs.Fields.Count - 1
TargetCell.Offset(0, i).Formula = rs.Fields(i).Name
Next i
Set TargetCell = TargetCell.Offset(1, 0)
End If
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close ' close the database connection
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "The source file or source range is invalid!", _
vbExclamation, "Get data from closed workbook"
End Sub
另一个不使用CopyFromRecordSet方法的方法使用下面的宏，您可以执行导入，并更好地控制从RecordSet返回的结果。
Sub TestReadDataFromWorkbook()
' fills data from a closed workbook in at the active cell
Dim tArray As Variant, r As Long, c As Long
tArray = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:B21")
' without transposing
' For r = LBound(tArray, 2) To UBound(tArray, 2)
' For c = LBound(tArray, 1) To UBound(tArray, 1)
' ActiveCell.Offset(r, c).Formula = tArray(c, r)
' Next c
' Next r
' with transposing
tArray = Application.WorksheetFunction.Transpose(tArray)
For r = LBound(tArray, 1) To UBound(tArray, 1)
For c = LBound(tArray, 2) To UBound(tArray, 2)
ActiveCell.Offset(r - 1, c - 1).Formula = tArray(r, c)
Next c
Next r
End Sub
Private Function ReadDataFromWorkbook(SourceFile As String, SourceRange As String) As Variant
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
' this function can only return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
' this function can return data from any worksheet in SourceFile
' SourceRange must include the range headers
' examples:
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:A21")
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:B21")
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "DefinedRangeName")
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ' open the database connection
Set rs = dbConnection.Execute("[" & SourceRange & "]")
On Error GoTo 0
ReadDataFromWorkbook = rs.GetRows ' returns a two dim array with all records in rs
rs.Close
dbConnection.Close ' close the database connection
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Function
InvalidInput:
MsgBox "The source file or source range is invalid!", vbExclamation, "Get data from closed workbook"
Set rs = Nothing
Set dbConnection = Nothing
End Function
该宏示例假定您的VBA项目已添加对ADO对象库的引用。
您可以通过在VBE中选择“工具”，“引用”并选择“ Microsoft ActiveX数据对象x.x对象库”来执行此操作。
如果可以在ADO和DAO之间进行数据导入或导出选择，请使用ADO。