マクロは無限のループで実行されています

debugcn 投稿 Dev

Josh Ng

現在、以下のスクリーンショットに示すような結果を達成したいと考えている一連のコードがあります。どういうわけか、それは無限のループで実行されます。どうすればそれを機能させることができるか考えていますか？

初期入力：

これに：

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

ティムウィリアムズ

あなたはこのようなことをすることができます：

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

この記事はインターネットから収集されたものであり、転載の際にはソースを示してください。

侵害の場合は、連絡してください[email protected]