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

Question

我打开了一个 Excel 2007 工作表，其中包含 5 列和 +/-5000 行数据。

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

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

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

非常感谢

Answer 1

试试这样的

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 2

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

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