有点复杂的数据处理，可能用到去重复和筛选。麻烦大佬了。

VBA小子白的很

每个表格有3000多行数据。平时需要处理多个表，每次手动操作，很麻烦。麻烦大师们了

VBA小子白的很

这个是原始和想要的结果的数据

microyip

尊敬的伸手党，你好

zpy2

VBA小子白的很 发表于 2019-9-28 12:13
这个是原始和想要的结果的数据

能不能问下为啥用这样改变啊？直接查询或筛选开头，相关的信息都有了啊？

VBA小子白的很

zpy2 发表于 2019-9-28 13:27
能不能问下为啥用这样改变啊？直接查询或筛选开头，相关的信息都有了啊？

想制作一个VBA处理，更快，手动操作会比较麻烦。

VBA小子白的很

microyip 发表于 2019-9-28 12:35
尊敬的伸手党，你好

发不了鲜花，没有这个选项

cnmlgb9998

1. Sub 货号()
   
2. Dim crr()
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set reg = CreateObject("vbscript.regexp")
   
5. arr = Sheets("原始数据").UsedRange
   
6. 
   
7. With reg
   
8.     .Pattern = "(-[A-Z]+)+"
   
9.     .Global = True
   
10.     For i = 2 To UBound(arr)
    
11.         x2 = arr(i, 2)
    
12.         If x2 <> "" Then
    
13.             ar = .Replace(x2, "")
    
14.             ar1 = Right(ar, Len(ar) - InStr(ar, "_"))
    
15.             ar2 = Left(ar, InStr(ar, "_") - 1)
    
16.             ark = ar1 + ar2
    
17.             d(ar) = IIf(d(ar) = "", IIf(.test(x2) = True, "!" & ark & "," & i, ark & "," & i), d(ar) & "," & i)
    
18.         End If
    
19.     Next
    
20. End With
    
21. 
    
22. For Each Key In d.keys
    
23.     brr = Split(d(Key), ",")
    
24.     If InStr(brr(0), "!") = False Then
    
25.         n = n + 1
    
26.         ReDim Preserve crr(1 To UBound(arr, 2), 1 To n)
    
27.         For m = 1 To UBound(crr)
    
28.             crr(m, n) = arr(brr(1), m)
    
29.         Next
    
30.     Else
    
31.         n = n + 1
    
32.         ReDim Preserve crr(1 To UBound(arr, 2), 1 To n)
    
33.         For m = 1 To UBound(crr)
    
34.             Select Case m
    
35.                 Case 2
    
36.                     crr(m, n) = Key
    
37.                 Case 8
    
38.                     crr(m, n) = Mid(brr(0), 2, Len(brr(0)) - 1)
    
39.                 Case 22
    
40.                     crr(m, n) = "Parent"
    
41.                 Case Else
    
42.                     crr(m, n) = arr(brr(1), m)
    
43.             End Select
    
44.         Next
    
45.         For s = 1 To UBound(brr)
    
46.             n = n + 1
    
47.             ReDim Preserve crr(1 To UBound(arr, 2), 1 To n)
    
48.             For m = 1 To UBound(crr)
    
49.                 If m = 22 Then
    
50.                     crr(m, n) = "Child"
    
51.                 Else
    
52.                     crr(m, n) = arr(brr(s), m)
    
53.                 End If
    
54.             Next
    
55.         Next
    
56.     End If
    
57. Next
    
58. Sheets("需要的处理后的数据").Activate
    
59. Set Rng = Range("A20").Resize(UBound(crr, 2), UBound(crr))
    
60. Rng.ClearContents
    
61. Rng.Value = Application.Transpose(crr)
    
62.    
    
63. End Sub
    

复制代码