VBA将数据从一个工作簿复制，粘贴和转置到其他工作簿
我使用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 使用getrows！ getrows方法从logging集转置types中获取数据。
昏暗的vDB
vDB = rsData.getRows
TargetRange.Cells（1，1）.resize（ubound（vDB，1）+ 1，Ubound（vDB，2）+1）= vDB
getRows函数将logging集的数据作为数组取而代之。 所以，这样的数组
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
使用这个一般例程转置一个范围：
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方法通常令人烦恼。 我们可以通过猜测复制logging的数量来克服它。 有两种方法是可能的：
1-记住CopyFromRecordset返回的logging数
2-作为“延迟修复”，从范围中获取复制行数：
TransposeRange(TargetRange.Resize(TargetRange.End(xlDown).Row + 1 -TargetRange.Row, _ rsData.Fields.Count))
最后 ，要注意，excel比列更有空间。 如果您的数据的logging数量超过了列数，那么操作是不可能的。