VBA 将数据从一个工作簿复制、粘贴和转置到另一个工作簿
VBA Copy, paste, and transpose data from one workbook to other workbook
我使用 ADO 中的这段代码在工作簿之间复制粘贴数据。第一个工作簿的数据是垂直的。我想将它复制并粘贴到水平位置的其他工作簿。我怎样才能用下面的代码做到这一点？提前致谢
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
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.ACE.OLEDB.12.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.ACE.OLEDB.12.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
使用这个通用例程转置一个范围：
Sub TransposeRange(r As Range)
Dim ar: ar = Application.Transpose(r.Value2)
r.ClearContents
r.Resize(r.Columns.Count, r.Rows.Count).value = ar
End Sub
要从您的代码中调用它，您可以在行 rsData.Close:
之前添加它
TransposeRange(TargetRange.Resize(rsData.RecordCount, rsData.Fields.Count))
Recordset 对象的方法RecordCount 经常让人头疼。我们可以通过不同方式猜测复制记录的数量来克服它。有两种可能的方法：
1- 记住CopyFromRecordset
返回的fected记录数
2-作为"lazy fix"，获取范围内复制的行数：
TransposeRange(TargetRange.Resize(TargetRange.End(xlDown).Row + 1 -TargetRange.Row, _
rsData.Fields.Count))
最后 ，请注意 excel 的行空间比列空间大得多。如果您的数据的记录多于列数，则无法进行操作。
使用getrows！ getrows 方法从记录集转置类型中获取数据。
昏暗的 vDB
vDB= rsData.getRows
TargetRange.Cells(1, 1).resize(ubound (vDB,1)+1,Ubound (vDB,2)+1)=vDB
getRows 函数获取记录集的数据作为数组，但转置。
所以，像这样的数组
vDB(0,0), vDB(0,1),....,vDB(0,n)
vdb(1,0), vdb(1,1),....,vDB(1,n)
.....
vDB(c,0), vDB(c,1), ...,vDB(c,n)
在这个例子中，n+1是recordcount，c+1是Fieldscount。
它也等于 Ubound(vdb,2)+1, Ubound(vDB,1)+1 .
这是全部代码。
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
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.ACE.OLEDB.12.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.ACE.OLEDB.12.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
Dim vDB
vDB = rsData.getRows
If Header = False Then
'TargetRange.Cells(1, 1).CopyFromRecordset rsData
TargetRange.Cells(1, 1).Resize(UBound(vDB, 1) + 1, UBound(vDB, 2) + 1) = vDB
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 + lCount, 1).Value = _
rsData.Fields(lCount).Name
Next lCount
'TargetRange.Cells(2, 1).CopyFromRecordset rsData
TargetRange.Cells(1, 2).Resize(UBound(vDB, 1) + 1, UBound(vDB, 2) + 1) = vDB
Else
TargetRange.Cells(1, 1).Resize(UBound(vDB, 1) + 1, UBound(vDB, 2) + 1) = vDB
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
我使用 ADO 中的这段代码在工作簿之间复制粘贴数据。第一个工作簿的数据是垂直的。我想将它复制并粘贴到水平位置的其他工作簿。我怎样才能用下面的代码做到这一点？提前致谢
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
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.ACE.OLEDB.12.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.ACE.OLEDB.12.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
使用这个通用例程转置一个范围：
Sub TransposeRange(r As Range)
Dim ar: ar = Application.Transpose(r.Value2)
r.ClearContents
r.Resize(r.Columns.Count, r.Rows.Count).value = ar
End Sub
要从您的代码中调用它，您可以在行 rsData.Close:
TransposeRange(TargetRange.Resize(rsData.RecordCount, rsData.Fields.Count))
Recordset 对象的方法RecordCount 经常让人头疼。我们可以通过不同方式猜测复制记录的数量来克服它。有两种可能的方法：
1- 记住CopyFromRecordset
2-作为"lazy fix"，获取范围内复制的行数：
TransposeRange(TargetRange.Resize(TargetRange.End(xlDown).Row + 1 -TargetRange.Row, _
rsData.Fields.Count))
最后 ，请注意 excel 的行空间比列空间大得多。如果您的数据的记录多于列数，则无法进行操作。
使用getrows！ getrows 方法从记录集转置类型中获取数据。
昏暗的 vDB
vDB= rsData.getRows
TargetRange.Cells(1, 1).resize(ubound (vDB,1)+1,Ubound (vDB,2)+1)=vDB
getRows 函数获取记录集的数据作为数组，但转置。 所以，像这样的数组
vDB(0,0), vDB(0,1),....,vDB(0,n)
vdb(1,0), vdb(1,1),....,vDB(1,n)
.....
vDB(c,0), vDB(c,1), ...,vDB(c,n)
在这个例子中，n+1是recordcount，c+1是Fieldscount。 它也等于 Ubound(vdb,2)+1, Ubound(vDB,1)+1 .
这是全部代码。
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
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.ACE.OLEDB.12.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.ACE.OLEDB.12.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
Dim vDB
vDB = rsData.getRows
If Header = False Then
'TargetRange.Cells(1, 1).CopyFromRecordset rsData
TargetRange.Cells(1, 1).Resize(UBound(vDB, 1) + 1, UBound(vDB, 2) + 1) = vDB
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 + lCount, 1).Value = _
rsData.Fields(lCount).Name
Next lCount
'TargetRange.Cells(2, 1).CopyFromRecordset rsData
TargetRange.Cells(1, 2).Resize(UBound(vDB, 1) + 1, UBound(vDB, 2) + 1) = vDB
Else
TargetRange.Cells(1, 1).Resize(UBound(vDB, 1) + 1, UBound(vDB, 2) + 1) = vDB
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