[已解决]麻烦老师指导如何在“帅老师”基础上进一步实现附件所述功能，谢谢！~

fywb2000

麻烦老师指导如何在“帅老师”基础上进一步实现附件所述功能，谢谢！~ 附件1-2.rar (50.28 KB, 下载次数: 3)

2013-2-19 23:34 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

cbg2008

2013-2-20 00:06

附件1-2.rar (48.07 KB, 下载次数: 11)

2013-2-20 00:05 上传

点击文件名下载附件

跳转到最佳答案楼层

cbg2008

附件1-2.rar (48.07 KB, 下载次数: 11)

2013-2-20 00:05 上传

点击文件名下载附件

fywb2000

cbg2008 发表于 2013-2-20 00:06

精妙!~高手老师真是数不胜数啊！~谢谢老师~

那么的帅

1. Sub 生成()
   
2.     With Sheets("data")
   
3.         Arr1 = .Range("A2:L7")
   
4.     End With
   
5.     Set D = CreateObject("Scripting.Dictionary")
   
6.     With Sheets("分析")
   
7.         ROW1 = .Range("B65536").End(xlUp).Row
   
8.         ARR2 = .Range("C2:I" & ROW1)
   
9.         ReDim ARR11(1 To UBound(ARR2), 1 To UBound(ARR2, 2))
   
10.         ReDim ARR12(1 To UBound(ARR2), 1 To UBound(ARR2, 2))
    
11.         ReDim arr13(1 To UBound(ARR2), 1 To UBound(ARR2, 2))
    
12.         For I = 1 To UBound(ARR2)
    
13.             M = 0
    
14.             For J = 1 To UBound(ARR2, 2)
    
15.                 y = False
    
16.                 For p = 2 To UBound(Arr1)
    
17.                     For q = 1 To UBound(Arr1, 2)
    
18.                         If ARR2(I, J) = Arr1(p, q) Then
    
19.                             y = True
    
20.                             ARR11(I, J) = Arr1(1, q)
    
21.                             Exit For
    
22.                         End If
    
23.                     Next q
    
24.                     If y = True Then Exit For
    
25.                 Next p
    
26.                 If Not D.Exists(ARR11(I, J)) Then
    
27.                     M = M + 1
    
28.                     D(ARR11(I, J)) = M
    
29.                     ARR12(I, M) = ARR11(I, J)
    
30.                     arr13(I, M) = Asc(ARR12(I, M)) - 64
    
31.                 End If
    
32.             Next J
    
33.             D.RemoveAll
    
34.         Next I
    
35.         With .Range("K2").Resize(UBound(ARR11), UBound(ARR11, 2))
    
36.             .ClearContents
    
37.             .Value = ARR11
    
38.         End With
    
39.         With .Range("S2").Resize(UBound(ARR12), UBound(ARR12, 2))
    
40.             .ClearContents
    
41.             .Value = ARR12
    
42.         End With
    
43.         With .Range("AA2").Resize(UBound(arr13), UBound(arr13, 2))
    
44.             .ClearContents
    
45.             .Value = arr13
    
46.         End With
    
47.     End With
    
48. 
    
49. End Sub
    
50. Sub 清空()
    
51.     With Sheets("分析")
    
52.         .Range("K2:Q65536").ClearContents
    
53.         .Range("S2:Y65536").ClearContents
    
54.         .Range("AA2:AG65536").ClearContents
    
55.     End With
    
56. End Sub

复制代码

附件1-2-1.rar (48.71 KB, 下载次数: 2)

2013-2-20 00:24 上传

点击文件名下载附件

fywb2000

那么的帅 发表于 2013-2-20 00:24

帅老师，非常感谢您！~谢谢！~只是不能再设置为最佳答案了！~