单元格条件拆分求教

maxmin168

liulang0808 发表于 2024-4-11 16:59
。。。。。。。。。。。。。

非常感谢老师，这下完美了。

liulang0808

Sub 按钮1_Click()
    w = 5
    arr = [a1].CurrentRegion
    brr = [a1].Resize(UBound(arr) * 5, 3)
    r = 1
    With CreateObject("vbscript.regexp")
        .Global = True
        .Pattern = "(\d+)(×.+?/)"
        For j = 2 To UBound(arr)
            If .test(arr(j, 3)) Then
                str1 = ""
                sm = 0
                For Each m In .Execute(arr(j, 3))
                    If sm + Val(m.submatches(0)) >= w Then
                        If Len(str1) > 0 Then
                            r = r + 1
                            brr(r, 1) = arr(j, 1)
                            brr(r, 2) = arr(j, 2)
                            brr(r, 3) = str1 & w - sm & m.submatches(1)
                            sm = Val(m.submatches(0)) - (w - sm)
                        Else
                            sm = Val(m.submatches(0))
                        End If
                        
                        
                        If sm > 0 Then
                            str1 = sm & m.submatches(1)
                            For i = w To sm Step w
                                r = r + 1
                                brr(r, 1) = arr(j, 1)
                                brr(r, 2) = arr(j, 2)
                                brr(r, 3) = w & m.submatches(1)
                            Next i
                            If sm Mod w <> 0 Then
                                
                                sm = sm - Int(sm / w) * w
                                str1 = sm & m.submatches(1)
                            Else
                                str1 = ""
                                sm = 0
                            End If
                        Else
                            str1 = ""
                            sm = 0
                        End If
                    Else
                        sm = sm + Val(m.submatches(0))
                        str1 = str1 & m.Value
                    End If
                Next m
                If Len(str1) > 0 Then
                    r = r + 1
                    brr(r, 1) = arr(j, 1)
                    brr(r, 2) = arr(j, 2)
                    brr(r, 3) = str1
                End If
            End If
        Next j
    End With
    [t1].Resize(r, 3) = brr
End Sub

liulang0808

修改w看看，是否是需要的结果吧

maxmin168

liulang0808 发表于 2024-4-11 18:57
修改w看看，是否是需要的结果吧

谢谢老师，这样需要时改一处就OK！