需要将行剪切并粘贴到上一行的末尾

Question

我准备开始学习VBA，以进行数据分析工作。我已经弄清楚了我需要使用多个“ IF”语句并复制和粘贴的方式，但是VBA会更干净。

我有来自医疗系统的数千行数据，它们按Excel每条记录为两行。我想取第二行（A-J单元格）并将其剪切并粘贴到第一行的末尾，从J处的第一个空单元格开始。

我尝试了许多不同的宏，但是每个宏仅执行我需要的一部分，而不是整个过程。我还没有找到其他人正在这样做。任何帮助将不胜感激。

    Sub CutMove()
    '
    ' CutMove Macro
    ' Cut and move 2nd Pt record row to column H of first
    '
    Dim X As Integer
        For X = 1 To 15 Step 3
            Range(Cells(3, 1), Cells(3, 10)).Select
            Selection.Cut
            Range("H" & X).Select
            ActiveSheet.Paste
        Next X
    End Sub

            Sub StackCopy_2()
     For Row = 2 To 15 Step 2
        Range("A3:J3" & Row).Cut
         ActiveSheet.Paste Destination:=Range("J" & Row - 1)
    Next Row
    End Sub

Excel文件片段：

Answer 1

在复制和清除之前，我已使用样本的数据生成了基本检查。应该对此进行调整，以适应更广泛的实际数据。

Option Explicit

Sub StackCopy()

    Dim i As Long

    With Worksheets("sheet9")

        'shuffle data up and right
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Step 2
            'simple check to see if column A follows pattern
            If Left(.Cells(i, "A"), 2) = "ER" And IsNumeric(.Cells(i + 1, "A")) Then
                .Cells(i, "J").Resize(1, 10) = .Cells(i + 1, "A").Resize(1, 10).Value
                .Cells(i + 1, "A").Resize(1, 10).Clear
            End If
        Next i

        'remove the blank rows
        With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
            .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With

    End With

End Sub

Answer 2

扩展行

调整代码以将结果复制到另一个工作表。像这样先尝试，如果对结果满意，请将目标工作表名称（cTarget）更改为与源工作表名称（ cSource）。不过，您将不得不手动编写其余的标题。

Option Explicit

Sub ExpandRows()

    Const cSource As String = "Sheet1"   ' Source Worksheet Name
    Const cCols1 As String = "A:I"       ' Source 1st Column Range Address
    Const cCols2 As String = "A:J"       ' Source 2nd Column Range Address
    Const cCrit As String = "ER"         ' Source Criteria
    Const cFR As Long = 2                ' Source First Row Number

    Const cTarget As String = "Sheet2"   ' Target Worksheet Name
    Const cTgtCell As String = "A2"      ' Target First Cell Address

    Dim vntS As Variant   ' Source Array
    Dim vntT As Variant   ' Target Array
    Dim Nor As Long       ' Source Number of Rows
    Dim Lr As Long        ' Source Last Row Number
    Dim Cols1 As Long     ' Source 1st Number of Columns
    Dim Cols2 As Long     ' Source 2nd Number of Columns
    Dim Cols As Long      ' Target Number of Columns
    Dim i As Long         ' Source Array Row Counter
    Dim j As Long         ' Source/Target Array Column Counter
    Dim k As Long         ' Target Number of Rows,
                          ' Target Array Row Counter

    ' In Source Worksheet (2nd Column Range)
    With ThisWorkbook.Worksheets(cSource).Columns(cCols2)
        ' Calculate Source Last Row Number.
        Lr = .Resize(.Rows.Count, 1) _
                .Find("*", , xlFormulas, , , xlPrevious).Row
        ' Copy Source Range to Source Array
        vntS = .Rows(cFR).Resize(Lr - cFR + 1)
        ' Calculate Source 1st Number of Columns.
        Cols1 = .Columns(cCols1).Columns.Count
        ' Calculate Source 2nd Number of Columns.
        Cols2 = .Columns(cCols2).Columns.Count
    End With

    ' Calculate Target Number of Columns.
    Cols = Cols1 + Cols2
    ' Calculate Source Number of Rows.
    Nor = UBound(vntS)

    ' Loop through rows of Source Array.
    For i = 1 To Nor
        ' Check value in current row and first column for Criteria.
        If Left(vntS(i, 1), 2) = cCrit Then
            ' Count Target Number of Columns.
            k = k + 1
        End If
    Next

    ' Resize Target Array.
    ReDim vntT(1 To k, 1 To Cols)

    ' Reset Target Row Counter.
    k = 0

    ' Loop through rows of Source Array.
    For i = 1 To Nor
        ' Check value in current row and first column for Criteria.
        If Left(vntS(i, 1), 2) = cCrit Then
            ' Count Target Number of Columns.
            k = k + 1
            ' Loop through Source 1st Number of Columns.
            For j = 1 To Cols1
                ' Write from Source to Target Array.
                vntT(k, j) = vntS(i, j)
            Next
            i = i + 1
            ' Loop through Source 2nd Number of Columns.
            For j = 1 To Cols2
                ' Write from Source to Target Array.
                vntT(k, j + Cols1) = vntS(i, j)
            Next
        End If
    Next

    ' In Target Worksheet (First Cell Address)
    With ThisWorkbook.Worksheets(cTarget).Range(cTgtCell)
        ' Clear Contents of range from Target First Cell Range to bottom row
        ' and Target Number of Columns wide.
        .Resize(.Worksheet.Rows.Count - .Row + 1, Cols).ClearContents
        ' Calculate Target Range.
        ' Copy Target Array to Target Range.
        .Resize(UBound(vntT), Cols) = vntT
    End With


End Sub