[已解决]请老师看一下这个VBA代码如何写

twtthduu

请老师看一下这个VBA代码如何写 代码求助.rar (6.35 KB, 下载次数: 21)

2012-1-14 08:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sunjing-zxl

2012-1-14 10:37

1. 
   
2. Sub aa()
   
3.     Dim d As New Dictionary
   
4.     Dim arr, arrt, Ar, i As Long, s As String
   
5.     arr = Range("C2:F" & [C65536].End(xlUp).Row)
   
6.     For i = 1 To UBound(arr)    '循环处理arr
   
7.         If Len(Trim(arr(i, 1))) Then    '如果数组arr不为空（既C列不为空）则：
   
8.             If Not d.Exists(arr(i, 1)) Then
   
9.                 d.Add arr(i, 1), 1    '将A列值（数组arr）装入父字典
   
10.                 Set d(arr(i, 1)) = New Dictionary    '同时定义每个父字典元素的子字典
    
11.             End If
    
12.             If d(arr(i, 1)).Exists(arr(i, 3)) Then
    
13.                 '如果子字典未赋值，则将E列值作为其key值，F列值作为其item值进行赋值；否则将item加上F列值
    
14.                 d(arr(i, 1))(arr(i, 3)) = d(arr(i, 1))(arr(i, 3)) + arr(i, 4)
    
15.             Else
    
16.                 d(arr(i, 1)).Add arr(i, 3), arr(i, 4)
    
17.             End If
    
18.         End If
    
19.     Next i
    
20.     If d.Count > 0 Then    '如果父字典个数大于0
    
21.         arr = d.Keys
    
22.         ReDim arrt(1 To UBound(arr) + 1, 1 To 4)  '重定义数组大小，以备生成H：K列数据
    
23.         For i = 1 To UBound(arrt)
    
24.             s = ""
    
25.             arrt(i, 1) = arr(i - 1)
    
26.             arrt(i, 3) = Application.Sum(d(arr(i - 1)).Items)  '合计总数量
    
27.             Ar = d(arr(i - 1)).Keys
    
28.             For j = 0 To UBound(Ar)
    
29.                 If Ar(j) = "左" Or Ar(j) = "右" Then
    
30.                     s = s & d(arr(i - 1))(Ar(j)) & Ar(j)
    
31.                 Else
    
32.                     s = Ar(j)
    
33.                 End If
    
34.             Next j
    
35.             arrt(i, 4) = s    '对子字典key值进行处理，处理成K列数据
    
36.             Set d(arr(i - 1)) = Nothing
    
37.         Next i
    
38.         Range("h2:k" & Rows.Count).ClearContents    '清除H：K列
    
39.         Range("h2").Resize(i - 1, 4) = arrt  '拷贝数组到H：K列
    
40.     End If
    
41.     Set d = Nothing
    
42. End Sub
    

复制代码

附件： 代码求助-sunjing.rar (14.16 KB, 下载次数: 21)

2012-1-14 10:39 上传

点击文件名下载附件

跳转到最佳答案楼层

twtthduu

给自己顶一下吧,要不然沉到底了.

sunjing-zxl

1. 
   
2. Sub aa()
   
3.     Dim d As New Dictionary
   
4.     Dim arr, arrt, Ar, i As Long, s As String
   
5.     arr = Range("C2:F" & [C65536].End(xlUp).Row)
   
6.     For i = 1 To UBound(arr)    '循环处理arr
   
7.         If Len(Trim(arr(i, 1))) Then    '如果数组arr不为空（既C列不为空）则：
   
8.             If Not d.Exists(arr(i, 1)) Then
   
9.                 d.Add arr(i, 1), 1    '将A列值（数组arr）装入父字典
   
10.                 Set d(arr(i, 1)) = New Dictionary    '同时定义每个父字典元素的子字典
    
11.             End If
    
12.             If d(arr(i, 1)).Exists(arr(i, 3)) Then
    
13.                 '如果子字典未赋值，则将E列值作为其key值，F列值作为其item值进行赋值；否则将item加上F列值
    
14.                 d(arr(i, 1))(arr(i, 3)) = d(arr(i, 1))(arr(i, 3)) + arr(i, 4)
    
15.             Else
    
16.                 d(arr(i, 1)).Add arr(i, 3), arr(i, 4)
    
17.             End If
    
18.         End If
    
19.     Next i
    
20.     If d.Count > 0 Then    '如果父字典个数大于0
    
21.         arr = d.Keys
    
22.         ReDim arrt(1 To UBound(arr) + 1, 1 To 4)  '重定义数组大小，以备生成H：K列数据
    
23.         For i = 1 To UBound(arrt)
    
24.             s = ""
    
25.             arrt(i, 1) = arr(i - 1)
    
26.             arrt(i, 3) = Application.Sum(d(arr(i - 1)).Items)  '合计总数量
    
27.             Ar = d(arr(i - 1)).Keys
    
28.             For j = 0 To UBound(Ar)
    
29.                 If Ar(j) = "左" Or Ar(j) = "右" Then
    
30.                     s = s & d(arr(i - 1))(Ar(j)) & Ar(j)
    
31.                 Else
    
32.                     s = Ar(j)
    
33.                 End If
    
34.             Next j
    
35.             arrt(i, 4) = s    '对子字典key值进行处理，处理成K列数据
    
36.             Set d(arr(i - 1)) = Nothing
    
37.         Next i
    
38.         Range("h2:k" & Rows.Count).ClearContents    '清除H：K列
    
39.         Range("h2").Resize(i - 1, 4) = arrt  '拷贝数组到H：K列
    
40.     End If
    
41.     Set d = Nothing
    
42. End Sub
    

复制代码

附件： 代码求助-sunjing.rar (14.16 KB, 下载次数: 21)

2012-1-14 10:39 上传

点击文件名下载附件

ddmyykdzh

学习               

szczm121

学习才是硬道理。

twtthduu

sunjing-zxl 发表于 2012-1-14 10:37
附件：

谢谢您孙晶,真的不错,您真的好利害呀!再次谢谢!达到要求了.