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）
'2007年12月30日，在Excel 2000-2007中工作
 Dim rsCon As Object 
 Dim rsData As Object 
 Dim szConnect As String 
 Dim szSQL As String 
 Dim lCount As Long 
'创建连接字符串。 
如果Header = False则
如果Val（Application.Version）< 12然后
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; &安培; _ 
Data Source =& SourceFile& ; &安培; _ 
扩展属性=Excel 8.0; HDR =否;; 
 Else 
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; &安培; _ 
Data Source =& SourceFile& ; &安培; _ 
扩展属性=Excel 12.0; HDR =否;; 
 End If 
 Else 
如果Val（Application.Version）< 12然后
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; &安培; _ 
Data Source =& SourceFile& ; &安培; _ 
扩展属性=Excel 8.0; HDR =是;; 
 Else 
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; &安培; _ 
Data Source =& SourceFile& ; &安培; _ 
扩展属性=Excel 12.0; HDR =是;; 
 End If 
 End If 
 
如果SourceSheet =然后
'工作簿级别名称
 szSQL =SELECT * FROM& SourceRange $& ; 
 Else 
'工作表级别名称或范围
 szSQL =SELECT * FROM [& SourceSheet $& $& SourceRange $& ]; 
结束如果
 
错误GoTo SomethingWrong 
 
设置rsCon = CreateObject（ADODB.Connection）
设置rsData = CreateObject（ADODB.Recordset ）
 
 rsCon.Open szConnect 
 rsData.Open szSQL，rsCon，0，1，1 
 
'检查以确保我们收到数据并复制数据
如果不是rsData.EOF然后
 
如果Header = False然后
 TargetRange.Cells（1，1）.CopyFromRecordset rsData 
 
 Else 
'如果最后一个参数为True，则添加每个列中的标题单元
如果UseHeaderRow然后
对于lCount = 0到rsData.Fields.Count  -  1 
 TargetRange.Cells（1，1 + lCount）.Value = _ 
 rsData.Fields（lCount）.Name 
 Next lCount 
 TargetRange.Cells（2，1）.CopyFromRecordset rsData 
 Else 
 TargetRange。单元格（1，1）.CopyFromRecordset rsData 
如果
结束If 
 
 Else 
 MsgBox没有记录返回f rom：& SourceFile，vbCritical 
 End If 
 
'清理我们的Recordset对象。 
 rsData.Close 
设置rsData = Nothing 
 rsCon.Close 
设置rsCon = Nothing 
退出子
  

解决方案

使用getrows！ getrows方法从记录集转置类型获取数据。

Dim 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） p>

在本示例中，n + 1是记录计数，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）
'2007年12月30日，在Excel 2000-2007中工作
 Dim rsCon As Object 
 Dim rsData As Object 
 Dim szConnect As String 
 Dim szSQL As String 
 Dim lCount As Long 
'创建连接字符串。 
如果Header = False则
如果Val（Application.Version）< 12然后
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; &安培; _ 
Data Source =& SourceFile& ; &安培; _ 
扩展属性=Excel 8.0; HDR =否;; 
 Else 
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; &安培; _ 
Data Source =& SourceFile& ; &安培; _ 
扩展属性=Excel 12.0; HDR =否;; 
 End If 
 Else 
如果Val（Application.Version）< 12然后
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; &安培; _ 
Data Source =& SourceFile& ; &安培; _ 
扩展属性=Excel 8.0; HDR =是;; 
 Else 
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; &安培; _ 
Data Source =& SourceFile& ; &安培; _ 
扩展属性=Excel 12.0; HDR =是;; 
 End If 
 End If 
 
如果SourceSheet =然后
'工作簿级别名称
 szSQL =SELECT * FROM& SourceRange $& ; 
 Else 
'工作表级别名称或范围
 szSQL =SELECT * FROM [& SourceSheet $& $& SourceRange $& ]; 
结束如果
 
错误GoTo SomethingWrong 
 
设置rsCon = CreateObject（ADODB.Connection）
设置rsData = CreateObject（ADODB.Recordset ）
 
 rsCon.Open szConnect 
 rsData.Open szSQL，rsCon，0，1，1 
 
'检查以确保我们收到数据并复制数据
如果不是rsData.EOF然后
 Dim vDB 
 vDB = rsData.getRows 
如果Header = False然后
'TargetRange.Cells（1，1）.CopyFromRecordset rsData 
 TargetRange.Cells（1，1）.Resize（UBound（vDB，1）+ 1，UBound（vDB，2）+ 1）= vDB 
 Else 
'每列如果最后一个参数为True 
如果UseHeaderRow然后
对于lCount = 0到rsData.Fields.Count  -  1 
 TargetRange.Cells（1 + lCount，1）.Value = _ 
 rsData.Fields（lCount）.Name 
下一个lCount 
'TargetRange.Cells（2，1）.CopyFromRecordset rsData 
 TargetRange.Cells（1，2）.Re大小（UBound（vDB，1）+ 1，UBound（vDB，2）+ 1）= vDB 
 Else 
 TargetRange.Cells（1，1）.Resize（UBound（vDB，1）+ 1 ，UBound（vDB，2）+ 1）= vDB 
如果
结束If 
 
 Else 
 MsgBoxNo records returned from：& SourceFile，vbCritical 
 End If 
 
'清理我们的Recordset对象。 
 rsData.Close 
设置rsData = Nothing 
 rsCon.Close 
设置rsCon = Nothing 
退出子
 SomethingWrong：
 MsgBox该文件名称，工作表名称或范围无效：& SourceFile，_ 
 vbExclamation，Error
 On Error GoTo 0 
 End Sub 
  

I used this code from ADO to copy paste data between workbook. The data from first workbook is vertical. I want to copy it and paste to other workbook in horizontal position. How can I do it with the code below? Thanks in advance

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

解决方案

Use getrows! getrows method get data from recordset transposed type.

Dim vDB

vDB= rsData.getRows

TargetRange.Cells(1, 1).resize(ubound (vDB,1)+1,Ubound (vDB,2)+1)=vDB

getRows Function get data of recordset as Array, but transposed. So, the array like this

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)

At this Example, n+1 is recordcount, c+1 is Fieldscount. It is also equeals Ubound(vdb,2)+1, Ubound(vDB,1)+1 .

This is All code.

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

这篇关于VBA将数据从一个工作簿复制，粘贴和转置到其他工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！