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

Question

我正在尝试复制一行中的一个单元格和相邻的单元格，并将其作为新行插入，该单元格右侧的所有数据也被复制过来。我的数据挖矿后是这样的

我试图让我的数据看起来像这样： 上图只是一个记录，但本质上是将所有人员及其在原始行中的相应位置移动到新行。每行大约有 5 名员工及其职位。

谢谢

编辑尝试的代码仅为 2 列。 1个位置。我们的想法是创建空行并使用自动填充复制其余数据，然后从那里开始工作

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