Excel VBA将多个列合并到不同的行中

我有一个excel 2007工作表打开5列和+/- 5000行数据。

我想要做的是创build一个macros，将会：

1. 在每条logging下插入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