VBA如何按条件删除，重排再拆分，请老师们有空看看，谢谢！！

13602822168

VBA如何按条件删除，重排再拆分，请老师们有空看看，谢谢！！

不知能否实现。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         c = .Range("aw6").End(xlToLeft).Column
   
8.         arr = .Range("ai6").Resize(1, c - 34)
   
9.         For j = 1 To UBound(arr, 2)
   
10.             d(CStr(arr(1, j))) = Empty
    
11.         Next
    
12.         r = .Columns("l:ac").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
13.         arr = .Range("l14:ac" & r)
    
14.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
15.         For j = 1 To UBound(arr, 2)
    
16.             m = 0
    
17.             For i = 1 To UBound(arr)
    
18.                 If InStr(arr(i, j), "-") <> 0 Then
    
19.                     xm = Split(arr(i, j), "-")
    
20.                     If Not d.exists(xm(1)) Then
    
21.                         m = m + 1
    
22.                         brr(m, j) = arr(i, j)
    
23.                     End If
    
24.                 End If
    
25.             Next
    
26.         Next
    
27.         .Range("ae14").Resize(UBound(brr), UBound(brr, 2)) = brr
    
28.         ReDim crr(1 To 4, 1 To 18 * 5)
    
29.         For j = 1 To UBound(brr, 2)
    
30.             n = j * 5 - 4
    
31.             For i = 1 To 5
    
32.                 If Len(brr(i, j)) = 0 Then
    
33.                     Exit For
    
34.                 End If
    
35.                 xm = Split(brr(i, j), "-")
    
36.                 crr(1, n) = brr(i, j)
    
37.                 crr(3, n) = xm(1)
    
38.                 crr(4, n) = xm(0)
    
39.                 n = n + 1
    
40.             Next
    
41.         Next
    
42.         .Range("ax14").Resize(1, UBound(crr, 2)).NumberFormatLocal = "@"
    
43.         .Range("ax14").Resize(UBound(crr), UBound(crr, 2)) = crr
    
44.                
    
45.     End With
    
46. End Sub
    

复制代码

chxw68

详见附件。

13602822168

chxw68 发表于 2024-9-6 07:19
详见附件。

强大！！！！！！感谢帮助！！！！！