复制单元格和相邻单元格并插入新行：Excel VBA

我试图将一个单元格和相邻的单元格复制到一行中，并将其作为一个新行插入，并将此单元格右侧的所有数据也复制过来。 我的数据在挖掘后看起来像这样。

并试图让我的数据看起来像这样： 上面的图片只是一条logging，本质上是把原来的所有人和他们相应的位置移动到了新的一行。 每行有大约5名员工和他们的职位。

谢谢

编辑尝试只有2色列的代码。 1个位置。 这个想法是创build空行，只是用自动填充复制其余的数据，然后从那里工作

Sub TransposeInsertRows() Dim rng As Range Dim i As Long, j As Long, k As Long Dim x As Long, y As Long Set rng = Application.InputBox _ (Prompt:="Range Selection...", _ Title:="Enter the name col and pos col", Type:=8) Application.ScreenUpdating = False x = rng(1, 1).Column + 2 y = rng(1, rng.Columns.Count).Column For i = rng(rng.Rows.Count, 1).Row To rng(1, 1).Row Step -1 If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then k = Cells(i, x - 2).End(xlToRight).Column If k > y Then k = y For j = k To x + 1 Step -1 Cells(i + 1, 1).EntireRow.Insert With Cells(i + 1, x - 2) .Value = .Offset(-1, 0) .Offset(0, 1) = .Offset(-1, 1) .Offset(0, 2) = Cells(i, j) End With Cells(i, j).ClearContents Next j End If Next i Application.ScreenUpdating = True End Sub 

Answer 1

如果每行总是有5个人，那么这应该做到这一点：

 Sub foo() LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row For i = 1 To LastRow 'loop through rows For x = 1 To 10 Step 2 'loop through columns LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'find the next free row on Sheet2 Sheet2.Cells(LastRow2, 1).Value = Sheet1.Cells(i, x).Value 'add Person Name to Sheet2 Sheet2.Cells(LastRow2, 2).Value = Sheet1.Cells(i, x + 1).Value 'add position to Sheet2 Sheet1.Range("K" & i & ":U" & i).Copy Destination:=Sheet2.Cells(LastRow2, 3) 'copy range from K to U to Sheet2 Next x Next i End Sub