Макрос работает в бесконечном цикле

Question

В настоящее время у меня есть набор кодов, ниже которого я надеюсь получить результаты, как показано на скриншотах ниже. Каким-то образом это просто работает в бесконечной л oop. Любая идея, как я могу заставить его работать?

Первоначальный ввод:

К этому :

Sub SplitAllCells()

    Dim rng1 As Range
    Dim Cla As Range
    Dim rng2 As Range
    Dim Clb As Range

    Set rng1 = Range("D2:D100")
    Set rng2 = Range("E2:E100")

    For Each Cla In rng1
            If Not IsEmpty(ActiveCell.Value) Then
                Call SplitCellValueSpecial
            End If
        Next

    For Each Clb In rng2
            If Not IsEmpty(ActiveCell.Value) Then
                Call SplitCellValueNormal
            End If
        Next


Sub SplitCellValueSpecial():

        Dim str As String
        Dim ArrStr() As String
        Dim i As Long
        Dim y As Long
        Dim RowsAdded As Boolean

        RowsAdded = False
        'Fill variables: str is the value of the active cell, ArrStr splits this value at the comma
        str = ActiveCell.Value
        ArrStr = Split(str, "~ ")

        'Loop through each ArrStr to populate each cell below the activecell

        For i = 0 To UBound(ArrStr)
            ActiveCell.Offset(i, 0).Value = ArrStr(i)
            If RowsAdded = False Then
                For y = 1 To UBound(ArrStr)
                    ActiveCell.Offset(1, 0).EntireRow.Insert xlDown
                Next y
                RowsAdded = True
            End If
        Next i


    End Sub

Sub SplitCellValueNormal():



    Dim str As String
    Dim ArrStr() As String

    'Fill variables: str is the value of the active cell, ArrStr splits this value at the comma
    str = ActiveCell.Value
    ArrStr = Split(str, "~ ")

    'Loop through each ArrStr to populate each cell below the activecell

    For i = 0 To UBound(ArrStr)
        ActiveCell.Offset(i, 0).Value = ArrStr(i)
    Next i


End Sub

Answer 1

Вы можете сделать что-то вроде этого:

Sub main()
    SplitCells Range("D2:D100")
    SplitCells Range("E2:E100")
End Sub

Sub SplitCells(rng As Range)
    Dim i, x, arr, arrV, v, el, c As Range

    arrV = rng.Value   'get the original values
    rng.ClearContents  'remove the content

    'loop over each value
    For i = 1 To UBound(arrV, 1)
        v = arrV(i, 1)
        If Len(v) > 0 Then
            arr = Split(v, "~") 'get an array
            For Each el In arr
                rng(1).Offset(x, 0).Value = el
                x = x + 1
            Next el
        Else
            x = x + 1
        End If
    Next i

End Sub

Answer 2

Попробуйте этот код, используя массивы (Вы можете поместить результаты в любую ячейку вместо D10)

Sub Test()
Dim a, x, e, i As Long, j As Long, k As Long, m As Long
a = Range("D3").CurrentRegion.Value
ReDim b(1 To 10000, 1 To UBound(a, 2))
For j = LBound(a, 2) To UBound(a, 2)
    k = 0
    For i = LBound(a) To UBound(a)
        x = Split(a(i, j), "~ ")
        For Each e In x
            k = k + 1
            b(k, j) = e
        Next e
        If k > m Then m = k
    Next i
Next j
Range("D10").Resize(m, UBound(b, 2)).Value = b
End Sub