Excel VBA每3行复制和转置数据

Question

I have this code to copy and transpose data. It only copy one column to one row. I want to copy data for every 3 row into multiple row. For example:

1        become         123
2                       456
3
4
5
6

This is my code to copy and transpose data. How can I do it like example above? Thanks for the help

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
        ' Copy and Transpose data to destination
        Dim vDB
        vDB = rsData.getRows
        If Header = False Then
            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, 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

You can use this code to transpose every 3 numbers into one row. Not sure if this is what you mean.

Sheet:

1    123
2    456
3    789
4
5
6
7
8
9

Code:

Sub BlaBlaBla()

Number = vbNullString
Row = 1
Count = 0
For i = 1 To 9
    Number = Number & CStr(Sheets(1).Range("A" & i))
    Count = Count + 1
    If Count = 3 Then
        Count = 0
        Sheets(1).Range("B" & Row) = Number
        Number = vbNullString
        Row = Row + 1
    End If
Next i

End Sub