VBA 1つのブックから他のブックにデータをコピー、貼り付け、転記

Question

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 

Answer 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はレコード数、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 

Answer 2

使用範囲移調するには、この一般的なルーチン：あなたのコードから呼び出す

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-によって返さfecthedレコードの数を暗記：

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

最後にですが、excelには列よりも行の余裕があることに注意してください。データの数が列数に収まらない場合は、操作は不可能です。