单元格条件拆分求教

maxmin168 · 发表于 2024-4-4 22:20

Sheet2是希望结果例示。
Sheet1运行VBA后，将C列的商品按数量不超过2个拆分成几列，相应的A列B列保持原样。结果输出在sheet1就可以，数量列只做条件参照。

表格1.rar (7.41 KB, 下载次数: 9)

liulang0808 · 发表于 2024-4-5 06:27

出现这样的情况要怎么分呢

liulang0808 · 发表于 2024-4-5 06:42

Sub 按钮1_Click()
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)) > 2 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
                     End If
                     str1 = m.Value
                     sm = Val(m.submatches(0))
                     For i = 2 To sm Step 2
                        r = r + 1
                        brr(r, 1) = arr(j, 1)
                        brr(r, 2) = arr(j, 2)
                        brr(r, 3) = 2 & Replace(str1, sm, "")
                     Next i
                     If sm Mod 2 <> 0 Then
                        str1 = 1 & Replace(str1, sm, "")
                        sm = 1
                     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
[k1].Resize(r, 3) = brr
End Sub

liulang0808 · 发表于 2024-4-5 06:42

附件内容供参考

maxmin168 · 发表于 2024-4-5 09:00

本帖最后由 maxmin168 于 2024-4-5 14:13 编辑

liulang0808 发表于 2024-4-5 06:27
出现这样的情况要怎么分呢

谢谢提示，确实提问局限了。

maxmin168 · 发表于 2024-4-5 10:30

本帖最后由 maxmin168 于 2024-4-5 14:44 编辑

liulang0808 发表于 2024-4-5 06:42
附件内容供参考

老师，拆分很完美，数量直接定义，数量列好像都无需参考了，但发现一个问题，有时候商品名称还会带有一些编号，或者是后缀纯数字的表示数量，比如1×苹果-6/2×橘子-K2/，是6个苹果和2个橘子总数为8。试了一下M2单元格可能需要计算，M3单元格拆分后成了2×橘子-K/ ,原来是2×橘子-K2/ 似乎跟数量门限的2有关，但就这第二个的2被删了。

数据拆分.rar (20.43 KB, 下载次数: 1)

liulang0808 · 发表于 2024-4-5 16:43

Sub 按钮1_Click()
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)) > 2 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
                     End If
                     str1 = m.Value
                     sm = Val(m.submatches(0))
                     For i = 2 To sm Step 2
                        r = r + 1
                        brr(r, 1) = arr(j, 1)
                        brr(r, 2) = arr(j, 2)
                        brr(r, 3) = 2 & Mid(str1, Len(sm) + 1)
                     Next i
                     If sm Mod 2 <> 0 Then
                        str1 = 1 & Mid(str1, Len(sm) + 1)
                        sm = 1
                     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
[p1].Resize(r, 3) = brr
End Sub

liulang0808 · 发表于 2024-4-5 16:44

附件内容供参考

maxmin168 · 发表于 2024-4-11 11:54

liulang0808 发表于 2024-4-5 16:44
附件内容供参考

老师，实际使用发现一个问题，就是按数量不超过2个拆分成几列，最好优先满足2个，如果最后剩下1个，那就只有这1个(M列标黄对比R列标黄部分)，不然会产生可以拆成2个但成了1个的情况(M列标红对比R列标红部分)。

数据拆分-new.rar (18.59 KB, 下载次数: 1)

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

。。。。。。。。。。。。。

		自动登录	找回密码
密码			免费注册

[求助] 单元格条件拆分求教

评分

评分

评分

评分

评分