请高手帮忙用宏完成从附件黄色表到绿色表的转变，说明见附件。非常感谢！

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Brr
   
3. Dim d, k, t, aa, j&, n&
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.ScreenUpdating = False
   
6. Sheet2.Activate
   
7. [a2:c50000].ClearContents
   
8. Arr = Sheet1.[a1].CurrentRegion
   
9. For i = 2 To UBound(Arr)
   
10.     d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
    
11. Next
    
12. Brr = Sheet3.[a1].CurrentRegion: n = 1
    
13. For i = 1 To UBound(Brr)
    
14.     If d.exists(Brr(i, 1)) Then
    
15.         t = d(Brr(i, 1))
    
16.         t = Left(t, Len(t) - 1)
    
17.         If InStr(t, ",") Then
    
18.             aa = Split(t, ",")
    
19.             For j = 0 To UBound(aa)
    
20.                 n = n + 1
    
21.                 Cells(n, 1).Resize(1, 3) = Application.Index(Arr, aa(j), 0)
    
22.             Next
    
23.         Else
    
24.             n = n + 1
    
25.             Cells(n, 1).Resize(1, 3) = Application.Index(Arr, t, 0)
    
26.         End If
    
27.     End If
    
28. Next
    
29. Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

蓝桥玄霜

请见附件。

peter1321

蓝桥玄霜 发表于 2015-1-12 09:14
如果是在同一个工作簿中，宏的使用可能会需要一点小的修改，也有的不需要修改。
如果是其他工作簿，只需要 ...

您好：
非常感谢您！在实际运用中，有时还要列数多一些，您发给我的名字为888的文件是12列，附件666666是20列的，能麻烦您再帮助修改下吗？

peter1321

附件666666是20列的，能麻烦您再帮助修改下吗？

蓝桥玄霜

不需要修改的，可正常运行。
取消AA列以后的隐藏即可看到结果。

peter1321

蓝桥玄霜 发表于 2015-1-13 08:58
不需要修改的，可正常运行。
取消AA列以后的隐藏即可看到结果。

您好：
真的非常感谢您的帮助！您是否能帮助看下附件能否实现。说明见附件内部。多谢

peter1321

您好：
真的非常感谢您的帮助！您是否能帮助看下附件能否实现。说明见附件内部。多谢！

LMY123

d(x)(y) = 1