Я на цыпочках изучаю VBA для своей работы по анализу данных. Я выяснил, что мне нужно сделать здесь с помощью нескольких операторов «IF» и копирования и вставки, но VBA был бы намного чище.

У меня есть много тысяч строк данных из нашей медицинской системы, и они попадают в Excel в виде двух строк на запись. Я хотел бы взять 2-ю строку (ячейки 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" amp; X).Select
            ActiveSheet.Paste
        Next X
    End Sub

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

Обрезка файла Excel:

Я использовал данные образца для создания элементарной проверки перед копированием и очисткой. Вероятно, это следует скорректировать в соответствии с более широким набором фактических данных.

 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
  

Развернуть строки

Код настроен для копирования результата на другой лист. Попробуйте сначала вот так, и если вы удовлетворены результатом, измените имя целевого листа ( 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