[已解决]多行信息分割到多行

山海风云轩

多行信息分割到多行，详情见图片附件。

注意：里面还有不同的分割符号。
如果有难度，给个相同分割符号的代码也行

最佳答案

月排行榜 / 总排行榜

林木水

2022-1-8 11:25

1. Sub demo()
   
2. Dim arr, i As Integer, m, mat, k1 As Integer, h As Integer
   
3. arr = Range("a3:b" & Cells(65536, 2).End(xlUp).Row)
   
4. 'Dim reg As New RegExp
   
5. Dim reg As Object
   
6. Set reg = CreateObject("vbscript.regexp")
   
7. For i = 1 To UBound(arr)
   
8. With reg
   
9.     .Global = True
   
10.     .Pattern = "\w\-\d{3}"
    
11.     Set mat = .Execute(arr(i, 2))
    
12.     For Each m In mat
    
13.         k1 = k1 + 1
    
14.         Cells(k1 + 2, "f") = m
    
15.         Cells(k1 + 2, "e") = arr(i, 1)
    
16.         Cells(k1 + 2, "g") = mat.Count
    
17.     Next m
    
18.         If mat.Count > 1 And Cells(k1 + 2, "e").Offset(-mat.Count + 1, 0).Resize(mat.Count).MergeCells = False Then
    
19.             Cells(k1 + 2, "e").Offset(-mat.Count + 1, 0).Resize(mat.Count).Merge
    
20.             Cells(k1 + 2, "g").Offset(-mat.Count + 1, 0).Resize(mat.Count).Merge
    
21.         End If
    
22. End With
    
23. Next i
    
24. End Sub
    

复制代码

最好是把你要做的附件放上去，因为你这个例子可能跟实际还是有区别的，以上代码可以解决例子问题，看下是否可行

跳转到最佳答案楼层

林木水

我来为你解答

山海风云轩

怎么解？

林木水

1. Sub demo()
   
2. Dim arr, i As Integer, m, mat, k1 As Integer, h As Integer
   
3. arr = Range("a3:b" & Cells(65536, 2).End(xlUp).Row)
   
4. 'Dim reg As New RegExp
   
5. Dim reg As Object
   
6. Set reg = CreateObject("vbscript.regexp")
   
7. For i = 1 To UBound(arr)
   
8. With reg
   
9.     .Global = True
   
10.     .Pattern = "\w\-\d{3}"
    
11.     Set mat = .Execute(arr(i, 2))
    
12.     For Each m In mat
    
13.         k1 = k1 + 1
    
14.         Cells(k1 + 2, "f") = m
    
15.         Cells(k1 + 2, "e") = arr(i, 1)
    
16.         Cells(k1 + 2, "g") = mat.Count
    
17.     Next m
    
18.         If mat.Count > 1 And Cells(k1 + 2, "e").Offset(-mat.Count + 1, 0).Resize(mat.Count).MergeCells = False Then
    
19.             Cells(k1 + 2, "e").Offset(-mat.Count + 1, 0).Resize(mat.Count).Merge
    
20.             Cells(k1 + 2, "g").Offset(-mat.Count + 1, 0).Resize(mat.Count).Merge
    
21.         End If
    
22. End With
    
23. Next i
    
24. End Sub
    

复制代码

最好是把你要做的附件放上去，因为你这个例子可能跟实际还是有区别的，以上代码可以解决例子问题，看下是否可行

hcm19522

E3{=OFFSET(A$2,SMALL(IF(LEN(B$3:B$5)-LEN(SUBSTITUTE(B$3:B$5,",",))+1>=COLUMN(A:I),{1;2;3},99),ROW(A1)),)&""

F3=IF(E3="","",TRIM(MID(SUBSTITUTE(VLOOKUP(E3,A:B,2,),",",REPT(" ",99)),COUNTIF(E$3:E3,E3)*99-98,99)))

G3=IF((COUNTIF(E$3:E3,E3)<>1)+(E3=""),"",COUNTIF(E:E,E3))

山海风云轩

林木水 发表于 2022-1-8 11:25
最好是把你要做的附件放上去，因为你这个例子可能跟实际还是有区别的，以上代码可以解决例子问题，看下是否 ...

感谢大佬，运行可以，
如果数据源是文字文本运行不了，可以帮忙修改吗？

山海风云轩

山海风云轩 发表于 2022-1-8 13:27
感谢大佬，运行可以，
如果数据源是文字文本运行不了，可以帮忙修改吗？

刚才附件网络问题没传上去

山海风云轩

hcm19522 发表于 2022-1-8 12:24
E3{=OFFSET(A$2,SMALL(IF(LEN(B$3:B$5)-LEN(SUBSTITUTE(B$3:B$5,",",))+1>=COLUMN(A:I),{1;2;3},99),ROW(A1 ...

谢谢大佬，
这个优先考虑VBA，应用于很多数据那种，这里只是节选举例

林木水

山海风云轩 发表于 2022-1-8 13:29
谢谢大佬，
这个优先考虑VBA，应用于很多数据那种，这里只是节选举例

1. Sub demo()
   
2. Dim arr, i As Integer, m, mat, k1 As Integer, h As Integer
   
3. arr = Range("a3:b" & Cells(65536, 2).End(xlUp).Row)
   
4. 'Dim reg As New RegExp
   
5. Dim reg As Object
   
6. Set reg = CreateObject("vbscript.regexp")
   
7. For i = 1 To UBound(arr)
   
8. With reg
   
9.     .Global = True
   
10.     .Pattern = "\w\-\d{3}|[\u4e00-\u9a5f]{1,}"
    
11.     Set mat = .Execute(arr(i, 2))
    
12.     For Each m In mat
    
13.         k1 = k1 + 1
    
14.         Cells(k1 + 2, "f") = m
    
15.         Cells(k1 + 2, "e") = arr(i, 1)
    
16.         Cells(k1 + 2, "g") = mat.Count
    
17.     Next m
    
18.         If mat.Count > 1 And Cells(k1 + 2, "e").Offset(-mat.Count + 1, 0).Resize(mat.Count).MergeCells = False Then
    
19.             Cells(k1 + 2, "e").Offset(-mat.Count + 1, 0).Resize(mat.Count).Merge
    
20.             Cells(k1 + 2, "g").Offset(-mat.Count + 1, 0).Resize(mat.Count).Merge
    
21.         End If
    
22. End With
    
23. Next i
    
24. End Sub
    

复制代码

改了第十行的正则表达式规则就可以了，你再试试。如果还有其他情况就在正则表达式上面添加规则就好

山海风云轩

林木水 发表于 2022-1-8 14:05
改了第十行的正则表达式规则就可以了，你再试试。如果还有其他情况就在正则表达式上面添加规则就好

666，可以了，谢谢大佬