Есть ли способ разделить и скопировать строки, где есть возврат каретки?

Question

У меня есть электронная таблица с большим количеством столбцов и строк.Внутри этих столбцов есть ячейки, в которых данные были объединены с использованием возврата каретки. На верхнем снимке экрана показаны данные, в первой строке 2 возврата каретки, а в имени резервной копии 1 строка 2, в столбце кода есть возврат каретки.перейти к таблице ниже:

Приведенный ниже код разбивает ячейки и вставляет их в конец.Затем я перемещаю исходные данные + 1 столбец в новую рабочую книгу.Вставьте разделенное значение обратно в правильный столбец.Затем вставьте это в новую рабочую книгу.Повторяйте до тех пор, пока не исчезнут дополнительные столбцы

    Sub SplitCarriageReturnsCostCodes()


    Sheets("Booking Details").Select

'This will cells where there is a carriage return

    Dim splitVals As Variant
    Dim totalVals As Long
    Dim CellstoSplit As Range
    Dim LastRow As Long          'Makes the last row check the last cell with data in'


    LastRow = Worksheets("Booking Details").Cells(Rows.Count, 5).End(xlUp).Row

    'Set range to split:
    Set CellstoSplit = Range("AG2", "AG2" & LastRow)

    For Each cell In CellstoSplit
    cell.Activate
    splitVals = Split(ActiveCell.Value, Chr(10))
    totalVals = UBound(splitVals)
    Range(Cells(ActiveCell.Row, ActiveCell.Column + 17), Cells(ActiveCell.Row, ActiveCell.Column + 17 + totalVals)).Value = splitVals
    'Pastes them on the end, from range of cell selected plus a number of cells count
    Next cell

End Sub

Sub CreateTabCostCodes()

    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)   'Adding sheet after all tabs
    ActiveWorkbook.Sheets(Worksheets.Count).Name = "Temp Sheet 1"     'Gives new sheet a name

    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)   'Adding sheet after all tabs
    ActiveWorkbook.Sheets(Worksheets.Count).Name = "Booking Details New"     'Gives new sheet a name


End Sub

Sub CopyandPasteCostCodes()
'
        'Dim I As Integer                            'Set I name as a variable
        'I = 1                                       'I = 1
        'Do While I <= 100


        Dim ColCount As Integer                     'Sets column count as an integer
        Dim I As Integer                            'Set I as interget
        intCol = ThisWorkbook.Sheets("Booking Details").UsedRange.Columns.Count
                                                    'counts column in my range I just created
        ColCount = intCol - 49                      'column count minus the pre existing columns
        Do While I <= ColCount                      'do while I is equal to or less than column count

        Dim LastRow As Long                     'Makes the last row check the last cell with data in'
        LastRow = Sheet1.Cells(Rows.Count, 5).End(xlUp).Row ' last row in column E = 5, count columns as per a Vlookup'

        Sheets("Booking Details").Select
        Range("A2", "AX2" & LastRow).Select
        Selection.Copy
        Sheets("Temp Sheet 1").Select
        Range("A1").Select
        ActiveSheet.Paste
        Range("AX1", "AX1" & LastRow).Select
        Application.CutCopyMode = False
        Selection.Cut
        Range("AG1").Select
        ActiveSheet.Paste
        Range("A1", "AW1" & LastRow).Select
        Selection.Cut
        Sheets("Booking Details New").Select
        Range("A100000").Select              'Find empty cell at bottom
        Selection.End(xlUp).Select          'Goes from bottom till it find data, xlup = go up'
        ActiveCell.Offset(1, 0).Select      'In this 1,0 then 1 is rows to offset, pastes below the copied data'.
                                            '0 is columns.
        ActiveSheet.Paste

    'Deletes column AW and moves the data along so I can pick it up again

        Sheets("Booking Details").Select
        'Columns("AW:AW").Select               'Before I fixed notes column
        Columns("AX:AX").Select
        Selection.Delete Shift:=xlToLeft

        I = I + 1                   'Add 1 to I up to my number above
    Loop

    Sheets("Booking Details New").Select
    Range("Z2").Select
    Selection.Copy
    Columns("AG:Ag").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

End Sub

Sub Copy_HeadersCostCodes()
'
' Copies headers from booking details to new tab

    Sheets("Booking Details").Select
    Rows("1:1").Select
    Range("AP1").Activate
    Selection.Copy
    Sheets("Booking Details New").Select
    Rows("1:1").Select
    ActiveSheet.Paste

    'Fixes a header that formats badly

    Sheets("Booking Details New").Select
    Range("Z1").Select
    Selection.Copy
    Range("AG1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

End Sub


Public Sub DeleteBlankRowsCostCodes()

'This deletes any row where there is a blank in column AA in the Bookings new tab'

    Dim lLRow As Long
    With Worksheets("Booking Details New") 'Select temp sheet tab'
     lLRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Looks from top to end of data in first column, hence rows.count, 1'
    .Range("AG:AG").AutoFilter Field:=1, Criteria1:=""
    .Range("AG2:AG" & lLRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlShiftUp
     .AutoFilterMode = False
     End With

End Sub

Работает, но чувствует себя тяжело руками.Все еще новичок в VBA, обучение на ходу