Split cells with carriage returns where result starts in different row (same column) and don't remove existing formula

Question

The code below splits then transposes the data, but the destination cell is also the cell that was being evaluated. As a result, it is overwriting the formula in the cell.
I need to keep the formula in the cell(s)and have the result start in a different cell (same column, different row). (See screenshot.)

Detail:
I have a report from a system that includes countless carriage returns within individual cells. (Some cells have over 2000 carriage returns.)
I need to split the cell contents into a vertical list for analysis, but I need the list to start in a cell lower down in the column.

The range of cells that have carriage return contents that need to be split: "h2:aa2".
Destination cells to start the list creation: "H8:aa8"

The code overwrites the formula that was in the cell.

1. How can I add the destination cell language into the code?

2. How can I remove blank rows in the destination cells?
   i.e. there is an extra carriage return between results. See screenshot.
   I can do this later using the Unique formula, but would love to not have to do that.

CODE:

Sub Splitcelldatawithcarriagereturnformultiplecolumns()
'VBA code to split out cell that has countless data with carriage returns
'Separates on carriage return, then transposes data. Result = vertical list"
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
Set WorkRng = Range("h2:aw2")
For Each Rng In WorkRng
    lLFs = VBA.Len(Rng) - VBA.Len(VBA.Replace(Rng, vbLf, ""))
    If lLFs > 0 Then
        Rng.Offset(1, 0).Resize(lLFs).Insert shift:=xlShiftDown
        Rng.Resize(lLFs + 1).Value = Application.WorksheetFunction.Transpose(VBA.Split(Rng, vbLf))
    End If
Next
End Sub

Where I failed: The section For Each Rng In WorkRng has Rng identified in countless locations as it splits then transposes the data. I tried replacing Rng with "H8:AA8" but that didn't work.

I believe I need to define the destination area, then assign it. (I also have found many different ways to remove the carriage return, but they seemed more cumbersome. (I am not sure if it is the most efficient code, but it works.)

Answer 1

EDIT: added worksheet loop and tabname check, and clears previous output

You could do it like this:

Option Explicit

Sub SplitCells()

    Dim c As Range, ws As Worksheet, v, arr, arr2, i As Long, x As Long, el
    Dim cOut As Range, wb As Workbook
    
    Set wb = ActiveWorkbook 'or ThisWorkbook
    
    For Each ws In wb.Worksheets                       '##loop all worksheets
        If LCase(ws.Name) Like "*exceptions*" Then     '##tabname contains "exceptions" ?
            For Each c In ws.Range("h2:aw2").Cells     'loop over range in row2
                
                Set cOut = c.EntireColumn.Cells(8)     'output starts here
                cOut.Resize(1000).ClearContents        '##clear any previous data
                
                v = Trim(c.Value)                      'remove any spaces
                If Len(v) > 0 Then                     'any content?
                    arr = Split(v, vbLf)                       'split on vbLf
                    ReDim arr2(LBound(arr) To UBound(arr))     'for consolidated array
                    x = LBound(arr2)
                    For i = LBound(arr) To UBound(arr)
                        el = Trim(arr(i))
                        If Len(el) > 0 Then  'non-blank?
                            arr2(x) = el     'add to consolidated array
                            x = x + 1        'next position
                        End If
                    Next i
                    'drop the array onto the sheet below the cell being processed
                    If x > LBound(arr) Then 'EDIT: added this check
                        cOut.Resize(x).Value = Application.Transpose(arr2)
                    End If
                End If
            Next c
        End If      'tab name contains "exceptions"
    Next ws
End Sub

Your second scenario:

Sub SplitCells()

    Dim c As Range, ws As Worksheet, rwData As Range
    Dim wb As Workbook, wsSumm As Worksheet, cOut As Range
    Dim arrJur, arrG1, arrG2, fileName, el
    
    Set wb = ActiveWorkbook                'or ThisWorkbook
    Set wsSumm = wb.Worksheets("Summary")  'summary sheet
    Set cOut = wsSumm.Range("A2")          'output starts here
    
    For Each ws In wb.Worksheets                       '##loop all worksheets
        If LCase(ws.Name) Like "*exceptions*" Then     '##tabname contains "exceptions" ?
            fileName = ws.Range("A1").Value
            Set rwData = ws.Range("A9:C9")
            Do While Application.CountA(rwData) > 0    'while have any data
                arrJur = CellValues(rwData.Cells(1))
                If Not IsEmpty(arrJur) Then            'any Jurisdictions?
                    arrG1 = CellValues(rwData.Cells(2))
                    arrG2 = CellValues(rwData.Cells(3))
                    For Each el In arrJur
                        cOut.Value = fileName               'file name
                        cOut.Offset(0, 1).Value = el        'jurisdiction
                        PutValues cOut.Offset(0, 2), arrG1  'group1
                        PutValues cOut.Offset(0, 27), arrG2 'group2
                        Set cOut = cOut.Offset(1) 'next output row
                    Next el
                
                End If
                Set rwData = rwData.Offset(1) 'next data row
            Loop
        End If      'tab name contains "exceptions"
    Next ws
End Sub

'If `arr` is not Empty, place it into a row starting at `c`
Sub PutValues(c As Range, arr)
    If Not IsEmpty(arr) Then
        c.Resize(1, UBound(arr) + 1).Value = arr
    End If
End Sub

'return an array of vbLf-separated non-blank values in a cell
Function CellValues(c As Range)
    Dim v As String, arr, col As New Collection, el
    v = Trim(c.Value)                      'remove any spaces
    If Len(v) > 0 Then                     'any content?
        arr = Split(v, vbLf)                       'split on vbLf
        For Each el In arr
            el = Trim(el)
            If Len(el) > 0 Then col.Add el 'non-blank?
        Next el
    End If
    CellValues = ColToArray(col)
End Function

'load a Collection to a 1D array
Function ColToArray(col As Collection)
    Dim i, arr
    If col.Count > 0 Then
        ReDim arr(0 To col.Count - 1)
        For i = 1 To col.Count
            arr(i - 1) = col(i)
        Next i
        ColToArray = arr
    Else
        ColToArray = Empty
    End If
End Function