2017-06-19 117 views
1

我使用ADO中的此代碼在工作簿之間複製粘貼數據。來自第一個工作簿的數據是垂直的。我想複製它並以橫向粘貼到其他工作簿。我如何用下面的代碼來做到這一點?在此先感謝VBA將數據從一個工作簿複製,粘貼並轉置到其他工作簿

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 
+1

檢查:[複製使用VBA Excel工作表之間的數據(https://www.codeproject.com/Tips/1187802/Copy-Data-Between-Excel-Sheets-using-VBA)如果你想要轉換數據,您有2個選項:1)使用[MS Access SQL轉換語句](https://msdn.microsoft.com/en-us/library/bb208956(v = office.12).aspx)或使用2 )Excel [轉置方法](https://msdn.microsoft.com/VBA/Excel-VBA/articles/worksheetfunction-transpose-method-excel) –

回答

1

使用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。 它也是eboundals 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 
+0

謝謝。它工作完美 –

1

使用此通用程序來移調範圍:

TransposeRange(TargetRange.Resize(rsData.RecordCount, rsData.Fields.Count)) 

的:

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之前添加此Recordset對象的方法RecordCount經常令人煩惱。我們可以通過不同的方式猜測複製記錄的數量來克服它。兩種方法是可能的:

1-記憶的由CopyFromRecordset

2-返回作爲「懶修復」 fecthed記錄的數目,得到複製的行從該範圍的數:

TransposeRange(TargetRange.Resize(TargetRange.End(xlDown).Row + 1 -TargetRange.Row, _ 
    rsData.Fields.Count)) 

最後,請注意,excel的行數多於列數的空間。如果您的數據記錄的數量超過了列數,那麼操作是不可能的。

+0

它不起作用。錯誤說「範圍無效」。 –

+0

@AdryanPermana'RecordCount'往往令人煩惱。嘗試添加到我的答案的任何其他方法。 –

相關問題