Excel VBA 在不同的行上将多列合并为一列

Excel VBA merge multiple columns into one on separate rows

提问by Shalan

I have an excel 2007 worksheet open with 5 colums and +/-5000 rows of data.

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

What I want to do is create a macro that will:

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

1. insert 3 blank rows under each record
2. copy the value in that row on column 1 and paste it in the 3 new rows in column 1
3. CUT the value from column 3 and place it in the first blank row beneath it in column 2
4. CUT the value from column 4 and place it in the next blank row beneath it in column 2
5. CUT the value from column 5 and place it in the next blank row beneath it in column 2

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

I am pulling out my hair trying to accomplish this but to no avail! please could someone assist me with this?

我正在拔头发试图做到这一点，但无济于事！请有人帮我解决这个问题吗？

Much thanks

非常感谢

回答by Joel Goodwin

Pass the worksheet to this particular function. It's not a complicated thing to do - I'd be interested to know what was going wrong with your approaches (it would have been good to post sample code in your question).

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

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

回答by Adriaan Stander

Try something like this

尝试这样的事情

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

回答by Fionnuala

How about:

怎么样：

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