我知道这个问题可能已经被问过,但我想知道是否有可能从另一个“关闭”的工作簿复制数据到我当前打开的工作簿。我试图查找一些东西,到处都说不可能......我知道这是一个开放式的问题。
啊,这让我回想起几年前的事情。我相信 Ron 几年前就已经做过了(在另一个平台上解释过)。但是有两种方法可以做到。一种方法我忘记了,需要逐个获取单元格,而另一种则是下面发布的 ADO 方法。首先有两个示例子程序(一种方法可带表头,另一种则不带),然后是主 ADO 子程序。
Option Explicit
Sub GetData_ExampleV1()
' It will copy the Header row also (the last two arguments are True)
' Change the last argument to False if you not want to copy the header row
GetData ThisWorkbook.Path & "\test.xlsx", "Sheet1", _
"A1:C5", Sheets("Sheet1").Range("A1"), True, True
End Sub
Sub GetData_ExampleC2()
' It will not copy the Header row (the last two arguments are True, False)
' Change the last argument to True if you also want to copy the header row
GetData ThisWorkbook.Path & "\test.xlsx", "Sheet1", _
"A1:C5", Sheets("Sheet1").Range("A1"), True, False
End Sub
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
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
' 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
screenupdating
设为 false。 - findwindow