Разделить ячейки по разрыву строки, сохраняя другие данные

Question

У меня есть несколько строк в электронной таблице, настроенной следующим образом:

TEST    1   Y   N    TEST_1            1234      Derived
                     TEST_2            56

Мне нужно разбить ячейки с разрывом строки при копировании оставшихся ячеек в новую строку:

TEST    1   Y   N    TEST_1            1234      Derived
TEST    1   Y   N    TEST_2            56        Derived

Я тестировал код, меняя разрывы строк на запятые (я не знаю символа VBA для перевода строки).Код, который я пробовал, работает только для одного столбца E, а не для столбца F:

Sub splitByCol()
  Dim r As Range, i As Long, ar
  Set r = Worksheets("Sheet1").Range("E999999:F999999").End(xlUp)
  Do While r.row > 1
    ar = Split(r.value, ",")
    If UBound(ar) >= 0 Then r.value = ar(0)
    For i = UBound(ar) To 1 Step -1
      r.EntireRow.Copy
      r.Offset(1).EntireRow.Insert
      r.Offset(1).value = ar(i)
    Next
    Set r = r.Offset(-1)
  Loop
End Sub

Answer 1

На самом деле вы были почти там:

• Вам нужно разделить на vbLf вместо ","
• Вам нужно разделить столбцы E и F на отдельные массивы

Итак, вы получите:

Option Explicit

Sub splitByCol()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim CurrentCell As Range
    Set CurrentCell = ws.Range("E" & ws.Rows.Count).End(xlUp)

    Dim ArrE As Variant   'split array for column E
    Dim ArrF As Variant   'split array for column F

    Do While CurrentCell.Row > 1
        ArrE = Split(CurrentCell.Value, vbLf)
        ArrF = Split(CurrentCell.Offset(ColumnOffset:=1).Value, vbLf)

        If UBound(ArrE) >= 0 Then CurrentCell.Value = ArrE(0)
        If UBound(ArrF) >= 0 Then CurrentCell.Offset(ColumnOffset:=1).Value = ArrF(0)

        Dim i As Long
        For i = UBound(ArrE) To 1 Step -1
            CurrentCell.EntireRow.Copy
            CurrentCell.Offset(1).EntireRow.Insert

            CurrentCell.Offset(1).Value = ArrE(i)
            If UBound(ArrF) >= i Then
                CurrentCell.Offset(1, 1).Value = ArrF(i)
            Else
                CurrentCell.Offset(1, 1).Value = vbNullString
            End If
        Next i
        Set CurrentCell = CurrentCell.Offset(-1)
    Loop
End Sub

Input

выход

Answer 2

Я только что сделал краткий тест, возможно, не идеален.Если у вас тонна строк и столбцов, это может быть слишком медленно.

    Dim rowiter As Long
    Dim coliter As Long
    Dim lastrow As Long
    Dim lastcol As Long
    Dim rowcount As Long
    Dim rowadd As Boolean
    With ActiveSheet
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastcol = .Cells.Find(What:="*", after:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        rowcount = lastrow + 1

        For rowiter = 1 To lastrow
            rowadd = False
            For coliter = 1 To lastcol
                If InStr(1, .Cells(rowiter, coliter), vbLf) Then
                    .Cells(rowcount, coliter).Value = Split(.Cells(rowiter, coliter), vbLf)(1)
                    .Cells(rowiter, coliter).Value = Split(.Cells(rowiter, coliter), vbLf)(0)
                    rowadd = True
                End If
            Next
            If rowadd = True Then
                For coliter = 1 To lastcol
                    If .Cells(rowcount, coliter).Value = "" Or IsNull(.Cells(rowcount, coliter).Value) Then
                        .Cells(rowcount, coliter).Value = .Cells(rowiter, coliter).Value
                    End If
                Next
                rowcount = rowcount + 1
            End If
            rowadd = False
        Next
        .Range(Cells(1, 1), Cells(rowcount, lastcol)).Sort Key1:=Columns("A"), Order1:=xlDescending
    End With