如何根据符号拆分大段的文字并分列填写标题？

zhuxucheng

limonet 发表于 2025-3-25 14:47
关键字：function

你好，这个代码怎么看。

limonet

zhuxucheng 发表于 2025-3-25 14:55
你好，这个代码怎么看。

2016及以上版本的PQ。

ykcbf1100

参与一下，全表自动生成

ykcbf1100

1. Sub ykcbf()   '//2025.3.25
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("原表").UsedRange
   
5.     ReDim brr(1 To UBound(arr), 1 To 100)
   
6.     m = 1: n = 4
   
7.     For j = 1 To 4
   
8.         brr(1, j) = arr(1, j)
   
9.     Next
   
10.     On Error Resume Next
    
11.     For i = 2 To UBound(arr)
    
12.         If arr(i, 1) <> Empty Then
    
13.             m = m + 1
    
14.             For j = 1 To 4
    
15.                 brr(m, j) = arr(m, j)
    
16.             Next
    
17.             For j = 5 To 6
    
18.                 st = ston(arr(i, j))
    
19.                 For x = 1 To UBound(st)
    
20.                     If Len(st(x)) Then
    
21.                         b = Split(st(x), "：")
    
22.                         s = b(0)
    
23.                         If Not d.exists(s) Then
    
24.                             n = n + 1
    
25.                             d(s) = n
    
26.                             brr(1, n) = s
    
27.                             brr(m, n) = b(1)
    
28.                         End If
    
29.                         c = d(b(0))
    
30.                         brr(m, c) = b(1)
    
31.                     End If
    
32.                 Next
    
33.             Next
    
34.         End If
    
35.     Next
    
36.     On Error Resume Next
    
37.     With Sheets("整理表")
    
38.         .UsedRange.Clear
    
39.         .Cells.Interior.ColorIndex = 0
    
40.         .[a1].Resize(1, n).Interior.Color = 49407
    
41.         .[a2].Resize(m - 1, 1).Interior.Color = 5296274
    
42.         With .[a1].Resize(m, n)
    
43.             .Value = brr
    
44.             .Borders.LineStyle = 1
    
45.             .HorizontalAlignment = xlCenter
    
46.             .VerticalAlignment = xlCenter
    
47.             With .Font
    
48.                 .Name = "微软雅黑"
    
49.                 .Size = 10
    
50.             End With
    
51.         End With
    
52.     End With
    
53.     Set d = Nothing
    
54.     Application.ScreenUpdating = True
    
55.     MsgBox "OK！"
    
56. End Sub
    
57. 
    
58. Function ston(st) As Variant
    
59.     Set reg = CreateObject("VBScript.RegExp")
    
60.     With reg
    
61.         .Global = True
    
62.         .Pattern = "(.*?)；"
    
63.         .IgnoreCase = True
    
64.     End With
    
65.     st = Replace(st, Chr(10), " ")
    
66.     st = Replace(st, ":", "：")
    
67.     st = Application.Trim(st)
    
68.     If reg.Test(st) Then
    
69.         Set mh = reg.Execute(st)
    
70.         ReDim result(1 To 30)
    
71.         m = 0
    
72.         For Each ma In mh
    
73.             m = m + 1
    
74.             result(m) = ma.SubMatches(0)
    
75.         Next
    
76.         ston = result
    
77.     End If
    
78. End Function
    

复制代码

半百

1. Sub test()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. ar = Sheets("原表").UsedRange.Resize(, 100)
   
4. n = 4
   
5. For i = 2 To UBound(ar)
   
6.     s = Replace(ar(i, 5) & "；" & ar(i, 6), ":", "：")
   
7.     a = Split(s, "；")
   
8.     For j = 0 To UBound(a)
   
9.         If a(j) <> "" Then
   
10.            b = Split("：" & a(j), "：")
    
11.            m = UBound(b)
    
12.             If Not d.exists(b(m - 1)) Then
    
13.                 n = n + 1
    
14.                 d(b(m - 1)) = n
    
15.                 ar(1, n) = b(m - 1)
    
16.             End If
    
17.             ar(i, d(b(m - 1))) = b(m)
    
18.         End If
    
19.     Next
    
20. Next
    
21. Sheets("整理表").[a1].Resize(i - 1, n) = ar
    
22. End Sub

复制代码

翁知江安

Sub test()
Dim i, j, k, m As Integer
Dim ar, br, cr, tepar1 As Variant
Dim e, kk
Dim d1, d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ar = Sheets("原表").[a1].CurrentRegion
For j = 5 To 6
   For i = 2 To UBound(ar)
    ar(i, j) = Replace(ar(i, j), ":", "：")
    ar(i, j) = Replace(ar(i, j), ";", "；")
    ar(i, j) = Replace(ar(i, j), "；-；", "/ /")
    tepar1 = Split(ar(i, j), "；")
    For Each e In tepar1
    If InStr(e, "：") > 0 And Len(e) > 3 Then
       d1(Split(e, "：")(0)) = d1(Split(e, "：")(0)) + 1
       d2(i & Split(e, "：")(0)) = Split(e, "：")(1)
    End If
    If Len(e) > 0 And InStr(e, "：") = 0 Then
       d1("") = "": d2(i & "") = e
    End If
    Next
   Next
Next
Sheets("效果").[a1].Resize(UBound(ar), 4) = ar
Sheets("效果").[e1].Resize(UBound(ar), 30).ClearContents
ReDim br(1 To 1, 1 To 30)
For Each kk In d1.keys
   If kk <> "" Then
     If d1(kk) = UBound(ar) - 1 Then
        m = m + 1: br(1, m) = kk
      End If
    Else
        m = m + 1: br(1, m) = kk
    End If
Next
Sheets("效果").[e1].Resize(1, m) = br
ReDim cr(1 To UBound(ar) - 1, 1 To m)
For i = 2 To UBound(ar)
   For j = 5 To m + 4
    cr(i - 1, j - 4) = d2(i & br(1, j - 4))
   Next
Next
Sheets("效果").[e2].Resize(UBound(ar) - 1, m) = cr
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正。

demonimissyou

参与一下………………