：：：求助::: 提取排列

excel玉米

wbgogo 发表于 2024-3-19 13:00
张三[5]       
张三[122]               
张三[2]               

你说的结果顺序是指你是先从左到右，然后从上到下吧？只要把循环顺序改下就可以了

swl4561255

1. Sub test()
   
2. Dim a As Range
   
3. Dim s As String
   
4. ar = Range("B6").End(4).Row
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. For Each a In Range("B6:E" & ar)
   
7.   If a <> "" Then
   
8.     s = Left(a.Value, InStr(a.Value, "[") - 1)
   
9.     d(s) = d(s) & "-" & a.Value
   
10.   End If
    
11. Next
    
12. k = d.keys
    
13. t = d.items
    
14. [H4].Resize(1, d.Count) = k
    
15. For i = 8 To 12
    
16.   mys = d(Cells(4, i).Value)
    
17.   brr = Split(Mid(mys, 2), "-")
    
18.   Cells(6, i).Resize(UBound(brr) + 1, 1) = Application.Transpose(brr)
    
19. Next
    
20. End Sub

复制代码

NBCBA123

1. Sub test()
   
2. last_row = Cells(Rows.Count, 5).End(xlUp).Row
   
3. arr = Range("b6:e" & last_row)
   
4. brr = [h4:k4]
   
5. Set reg = CreateObject("vbscript.regexp")
   
6. reg.Global = True
   
7. reg.Pattern = "[^\u4e00-\u9fa5]+"
   
8. Set dic = CreateObject("scripting.dictionary")
   
9. For a = 1 To UBound(brr, 2)
   
10.     If Not dic.exists(brr(1, a)) Then Set dic(brr(1, a)) = CreateObject("scripting.dictionary")
    
11. Next a
    
12. For b = 1 To UBound(arr)
    
13.     For c = 1 To UBound(arr, 2)
    
14.     ss = reg.Replace(arr(b, c), "")
    
15.         If dic.exists(ss) Then
    
16.             If Not dic(ss).exists(arr(b, c)) Then Set dic(ss)(arr(b, c)) = CreateObject("scripting.dictionary")
    
17.             dic(ss)(arr(b, c)) = ""
    
18.         End If
    
19.     Next c
    
20. Next b
    
21. For d = 1 To UBound(brr, 2)
    
22.     drr = dic(brr(1, d)).keys
    
23.     Cells(6, "m").Offset(0, k).Resize(UBound(drr) + 1) = Application.Transpose(drr)
    
24.     k = k + 1
    
25. Next d
    
26. End Sub

复制代码

笨鸟飞不高

cha_pai_111.zip (16.91 KB, 下载次数: 3)

2024-3-19 14:46 上传

点击文件名下载附件

wbgogo

笨鸟飞不高 发表于 2024-3-19 14:46

谢谢！  鲜花改日送上！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.19
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("Sheet1")
   
4.         arr = .[h4:k4]
   
5.         For j = 1 To UBound(arr, 2)
   
6.             d(arr(1, j)) = j
   
7.         Next
   
8.         ReDim brr(1 To 1000, 1 To d.Count)
   
9.         r = .Cells(Rows.Count, 2).End(3).Row
   
10.         arr = .[b1].Resize(r, 4)
    
11.         For Each k In d.keys
    
12.             m = 0
    
13.             For i = 2 To UBound(arr)
    
14.                 If InStr(arr(i, 1), k) Then
    
15.                     m = m + 1
    
16.                     brr(m, d(k)) = arr(i, 1)
    
17.                 End If
    
18.                 If InStr(arr(i, 4), k) Then
    
19.                     m = m + 1
    
20.                     brr(m, d(k)) = arr(i, 4)
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.         .Range("h6:k" & r) = ""
    
25.         .[h6].Resize(r - 4, 4) = brr
    
26.     End With
    
27.     Set d = Nothing
    
28.     MsgBox "OK！"
    
29. End Sub
    

复制代码