宏程序无休止地循环运行

目前,我有一套下面的代码,我希望能达到如下截图所示的效果。不知道为什么,它只是在无休止地循环运行。有什么办法可以让它正常运行吗?

初始输入。

enter image description here

对这个:

enter image description here

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

给TA打赏
共{{data.count}}人
人已打赏
未分类

分离式滑动兄弟姐妹,一个兄弟姐妹影响另一个兄弟姐妹的悬停。

2022-9-8 17:14:17

未分类

如何以正确的方式调试Dynamics 365 Business Central ( Wave2 ) ?

2022-9-8 17:14:19

0 条回复 A文章作者 M管理员
    暂无讨论,说说你的看法吧
个人中心
购物车
优惠劵
今日签到
有新私信 私信列表
搜索