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

peter1321

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

ctp_119

做什么用，这个不难，又是彩票吗？

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, x, y$, k1, j&, Brr
   
3. Dim d, k, t, d1
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. [m:z].Clear
   
7. Arr = Sheet1.UsedRange
   
8. For j = 1 To UBound(Arr, 2)
   
9.     x = Arr(2, j)
   
10.     If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
11.     For i = 3 To UBound(Arr)
    
12.         y = Arr(i, j)
    
13.         If y <> "" Then
    
14.             d(x)(y) = 1
    
15.             d1(y) = ""
    
16.         End If
    
17.     Next
    
18. Next
    
19. k = d.keys: t = d.items: k1 = d1.keys
    
20. [n2].Resize(1, d.Count) = k
    
21. [m3].Resize(d1.Count) = Application.Transpose(k1)
    
22. Brr = [m2].CurrentRegion
    
23. For j = 2 To UBound(Brr, 2)
    
24.     x = Brr(1, j)
    
25.     For i = 2 To UBound(Brr)
    
26.         y = Brr(i, 1)
    
27.         If d(x).exists(y) Then Brr(i, j) = d(x)(y)
    
28.     Next
    
29. Next
    
30. [m2].CurrentRegion = Brr
    
31. [m2].CurrentRegion.Sort [m3], 1, Header:=xlYes
    
32. [m2].CurrentRegion.Borders.LineStyle = 1
    
33. End Sub
    

复制代码

蓝桥玄霜

请见附件。

peter1321

蓝桥玄霜 发表于 2015-1-10 10:22
请见附件。

非常感谢您。我不太懂VBA，在附件“888”运行了之后报错如附件“截屏”，能否请您帮助修改？多谢！

peter1321

非常感谢您。我不太懂VBA，在附件“888”运行了之后报错如附件“截屏”，能否请您帮助修改？多谢！

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, x, y$, k1, j&, Brr
   
3. Dim d, k, t, d1
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set d1 = CreateObject("Scripting.Dictionary")
   
6. [aa:az].Clear
   
7. Arr = Sheet1.UsedRange
   
8. For j = 1 To UBound(Arr, 2)
   
9.     x = Arr(1, j)
   
10.     If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    
11.     For i = 2 To UBound(Arr)
    
12.         y = Arr(i, j)
    
13.         If y <> "" Then
    
14.             d(x)(y) = 1
    
15.             d1(y) = ""
    
16.         End If
    
17.     Next
    
18. Next
    
19. k = d.keys: t = d.items: k1 = d1.keys
    
20. [ab1].Resize(1, d.Count) = k
    
21. [aa2].Resize(d1.Count) = Application.Transpose(k1)
    
22. Brr = [aa1].CurrentRegion
    
23. For j = 2 To UBound(Brr, 2)
    
24.     x = Brr(1, j)
    
25.     For i = 2 To UBound(Brr)
    
26.         y = Brr(i, 1)
    
27.         If d(x).exists(y) Then Brr(i, j) = d(x)(y)
    
28.     Next
    
29. Next
    
30. [aa1].CurrentRegion = Brr
    
31. [aa1].CurrentRegion.Sort [aa2], 1, Header:=xlYes
    
32. [aa1].CurrentRegion.Borders.LineStyle = 1
    
33. End Sub
    

复制代码

蓝桥玄霜

代码与数据的位置有很大的关系。
请见附件。

peter1321

蓝桥玄霜 发表于 2015-1-11 10:12
代码与数据的位置有很大的关系。
请见附件。

怎样将一个工作表的全部内容（包括宏）复制到另一个工作表中

蓝桥玄霜

如果是在同一个工作簿中，宏的使用可能会需要一点小的修改，也有的不需要修改。
如果是其他工作簿，只需要把模块1拖拉过去即可。
如果不会做，就把附件作为模板，改变数据即可。