Excel VBA将多列合并为单独的一行

Question

我有一个Excel 2007工作表，其中有5个列和+/- 5000行数据。

我想做的是创建一个宏，该宏将：

1. 在每条记录下插入3个空白行
2. 将值复制到第1列的该行中，然后将其粘贴到第1列的3个新行中
3. 从第3列中截取值，并将其放在第2列中其下方的第一空白行中
4. 从第4列中剪切出该值，并将其放在第2列中它下方的下一个空白行中
5. 从第5列中剪切出该值，并将其放在第2列中它下方的下一个空白行中

我正在拔头发试图做到这一点，但无济于事！ 请有人可以帮助我吗？

非常感谢

Answer 1

将工作表传递给此特定功能。 这不是一件复杂的事情-我很想知道您的方法出了什么问题（将示例代码发布在您的问题中会很好）。

Public Sub splurge(ByVal sht As Worksheet)

    Dim rw As Long
    Dim i As Long

    For rw = sht.UsedRange.Rows.Count To 1 Step -1
        With sht
            Range(.Rows(rw + 1), .Rows(rw + 3)).Insert
            For i = 1 To 3
                ' copy column 1 into each new row
                .Cells(rw, 1).Copy .Cells(rw + i, 1)
                ' cut column 3,4,5 and paste to col 2 on next rows
                .Cells(rw, 2 + i).Cut .Cells(rw + i, 2)
            Next i
        End With
    Next rw

End Sub

Answer 2

试试这个

Sub Macro1()
Dim range As range
Dim i As Integer

Dim RowCount As Integer
Dim ColumnCount As Integer
Dim sheet As worksheet
Dim tempRange As range
Dim valueRange As range
Dim insertRange As range

    Set range = Selection
    RowCount = range.Rows.Count
    ColumnCount = range.Columns.Count
    For i = 1 To RowCount
        Set sheet = ActiveSheet

        Set valueRange = sheet.range("A" & (((i - 1) * 4) + 1), "E" & (((i - 1) * 4) + 1))

        Set tempRange = sheet.range("A" & (((i - 1) * 4) + 2), "E" & (((i - 1) * 4) + 2))
        tempRange.Select
        tempRange.Insert xlShiftDown
        Set insertRange = Selection
        insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
        insertRange.Cells(1, 2) = valueRange.Cells(1, 3)
        valueRange.Cells(1, 3) = ""

        Set tempRange = sheet.range("A" & (((i - 1) * 4) + 3), "E" & (((i - 1) * 4) + 3))
        tempRange.Select
        tempRange.Insert xlShiftDown
        Set insertRange = Selection
        insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
        insertRange.Cells(1, 2) = valueRange.Cells(1, 4)
        valueRange.Cells(1, 4) = ""

        Set tempRange = sheet.range("A" & (((i - 1) * 4) + 4), "E" & (((i - 1) * 4) + 4))
        tempRange.Select
        tempRange.Insert xlShiftDown
        Set insertRange = Selection
        insertRange.Cells(1, 1) = valueRange.Cells(1, 1)
        insertRange.Cells(1, 2) = valueRange.Cells(1, 5)
        valueRange.Cells(1, 5) = ""

    Next i
End Sub

Answer 3

怎么样：

Dim cn As Object
Dim rs As Object

strFile = Workbooks(1).FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open strCon

strSQL = "SELECT t.F1, t.Col2 FROM (" _
       & "SELECT F1, 1 As Sort, F3 As Col2 FROM [Sheet1$] " _
       & "UNION ALL " _
       & "SELECT F1, 2 As Sort, F4 As Col2 FROM [Sheet1$] " _
       & "UNION ALL " _
       & "SELECT F1, 3 As Sort, F5 As Col2 FROM [Sheet1$] ) As t " _
       & "ORDER BY F1, Sort"

rs.Open strSQL, cn

Worksheets("Sheet6").Cells(2, 1).CopyFromRecordset rs