把一列中的数分出来按订单

mcy318

变成图中的这样子，代码怎么写

醉眼看尘世

1. Sub test()
   
2. Dim reGxp As Object, i&, tmPobj As Object, m As Object, Arr, jL&, Brr(1 To 6), Dic As Object, sH As Worksheet
   
3. Arr = ActiveSheet.[a1].CurrentRegion
   
4. Set Dic = CreateObject("scripting.dictionary")
   
5. Set reGxp = CreateObject("vbScript.regExp")
   
6. reGxp.Global = True
   
7. reGxp.Pattern = "产品型号\:([^\|]+) \| 数量\:(\d+(\.\d+)?) \| 单价（含税）\:(\d+(\.\d+)?) \| 销售额（含税）\:(\d+(\.\d+)?)"
   
8. jL = 0
   
9. With reGxp
   
10.     For i = 2 To UBound(Arr, 1)
    
11.         If .test(Arr(i, 5)) Then
    
12.             Set tmPobj = .Execute(Arr(i, 5))
    
13.             For Each m In tmPobj
    
14.                 jL = jL + 1
    
15.                 Brr(1) = Arr(i, 1)
    
16.                 Brr(2) = Arr(i, 4)
    
17.                 Brr(3) = m.submatches(0)
    
18.                 Brr(4) = Val(m.submatches(1))
    
19.                 Brr(5) = Val(m.submatches(3))
    
20.                 Brr(6) = Val(m.submatches(5))
    
21.                 Dic(jL) = Brr
    
22.             Next m
    
23.         End If
    
24.     Next i
    
25. End With
    
26. If Dic.Count = 0 Then Exit Sub
    
27. Set sH = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
28. With sH
    
29.     .Name = Format(Now, "结果yymmhhss")
    
30.     .[a1].Resize(1, 6) = Array("订单号", "客户", "型号", "数量", "单价", "销售额")
    
31.     .[a2].Resize(Dic.Count, 2).NumberFormat = "@"
    
32.     ReDim Crr(1 To Dic.Count, 1 To 6)
    
33.     For Each d In Dic.keys
    
34.         Arr = Dic(d)
    
35.         For j = 1 To 6
    
36.             Crr(d, j) = Arr(j)
    
37.         Next j
    
38.     Next d
    
39.     .[a2].Resize(UBound(Crr, 1), UBound(Crr, 2)) = Crr
    
40.    
    
41. End With
    
42. End Sub
    

复制代码

mcy318

谢谢，老师热心解答

ww87725244

1. Sub aa()
   
2. Dim ar, i, ar1(1 To 10000, 1 To 6), k, d, m, n, s, s1, j, p
   
3. Set d = CreateObject("vbscript.regexp")
   
4. ar = Sheet1.UsedRange
   
5. With d
   
6.     .Global = True
   
7.     .Pattern = "[A-Z]+.*?(\s|[A-Z]\s)|\d+(?=\.)"
   
8. End With
   
9. For i = 2 To UBound(ar)
   
10.     If InStr(ar(i, 5), Chr(10)) Then
    
11.         s = Len(ar(i, 5)) - Len(Replace(ar(i, 5), Chr(10), ""))
    
12.         For k = 0 To s
    
13.             s1 = Split(ar(i, 5), Chr(10))(k)
    
14.             If s1 <> "" Then
    
15.                 j = j + 1
    
16.                 ar1(j, 1) = ar(i, 1)
    
17.                 ar1(j, 2) = ar(i, 4)
    
18.                 Set m = d.Execute(s1)
    
19.                 For n = 0 To m.Count - 1
    
20.                     ar1(j, n + 3) = m(n)
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.         p = j
    
25.     Else
    
26.         p = p + 1
    
27.         s1 = ar(i, 5)
    
28.         ar1(p, 1) = ar(i, 1)
    
29.         ar1(p, 2) = ar(i, 4)
    
30.         Set m = d.Execute(s1)
    
31.         For n = 0 To m.Count - 1
    
32.             ar1(p, n + 3) = m(n)
    
33.         Next
    
34.     End If
    
35. Next
    
36. Sheet2.[a1].Resize(UBound(ar1), UBound(ar1, 2)) = Array("销售订单", "客户名称", "产品型号", "数量", "单价（含税）", "销售额（含税）")
    
37. Sheet2.[a2].Resize(UBound(ar1), UBound(ar1, 2)) = ar1
    
38. Set d = Nothing
    
39. End Sub

复制代码

ww87725244

参与一下，不知是否符合要求

mcy318

谢谢老师回复

Qs18

Sub qs()
Dim arr, i
With Sheet1
    arr = .Range("a1").CurrentRegion.Value
    ReDim brr(1 To 10000, 1 To 6)
    For i = 2 To UBound(arr)
    s = Split(arr(i, 5), ";")
    For y = 0 To UBound(s)
        m = m + 1
        brr(m, 1) = "'" & arr(i, 1): brr(m, 2) = arr(i, 4)
        ar = Split(Trim(s(y)), "|")
            x = 2
        For j = LBound(ar) To 3
            x = x + 1
            brr(m, x) = Split(Trim(ar(j)), ":")(1)
        Next j
    Next y
    Next
End With
b = [{"销售订单","客户名称","产品型号","数量","单价","销售额"}]
Sheet2.Range("a1").Resize(, 6) = b
Sheet2.Range("a2").Resize(m, 6) = brr
End Sub

Qs18

试试............

Qs18

试试.............

ykcbf1100

正则参与一下