按关键词，行号位置提取数据

飞天篮球猪

供参考...

一烟难禁

好久没有答题了,凑个数

佛山小老鼠

学习了10楼的方法，我也写了一次，活到老，学到老

1. Option Explicit
   
2. Sub test()
   
3.   Dim arr1, arr2, Dic, x, arr3
   
4.   Dim arr4(1 To 10000, 1 To 3), y, k
   
5.   Set Dic = CreateObject("Scripting.dictionary")
   
6.   arr1 = Range("A1").CurrentRegion
   
7.   arr2 = Range("D1").CurrentRegion
   
8.   For x = 2 To UBound(arr2)
   
9.     arr3 = Split(arr2(x, 2), "-")
   
10.     For y = arr3(0) To arr3(1)
    
11.       If Not Dic.exists(y) Then
    
12.         k = k + 1
    
13.         Dic(y) = ""
    
14.         arr4(k, 1) = arr2(x, 1)
    
15.         arr4(k, 2) = arr1(y, 1)
    
16.         arr4(k, 3) = arr1(y, 2)
    
17.       End If
    
18.     Next y
    
19.   Next x
    
20.   [G2].Resize(k, 3) = arr4
    
21. End Sub
    

复制代码