[已解决]用VBA提取数据

蓝天一片云

从A1:C13区域中提取数据.如果A列编号相同，C列数据正负抵消就不提取数据，只提取大于0的数据，不提取小于0的数据，结果见F1:H3区域。谢谢！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-2-3 14:47

1. Sub 提取数据()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : 提取数据
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/2/3
   
6. ' Purpose   : 字典+数组
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9.     Dim arr, Lastrow&, result()
   
10.     Dim key$, l&, i&, dickey
    
11. 
    
12.     '取最后一行数据所在行
    
13.     Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    
14.     '读取数据
    
15.     arr = Range("a1:c" & Lastrow)
    
16. 
    
17.     '字典
    
18.     Dim dic As Object
    
19.     Set dic = CreateObject("scripting.dictionary")
    
20.     '编号|名称做为关键字
    
21.     For i = LBound(arr) + 1 To UBound(arr)
    
22.         key = arr(i, 1) & "|" & arr(i, 2)
    
23.         dic(key) = dic(key) + arr(i, 3)
    
24.     Next
    
25.     '定义结果数组
    
26.     ReDim result(1 To dic.Count, 1 To 3)
    
27.     For Each dickey In dic.keys
    
28.         '统计数量为正值者写入结果数组
    
29.         If dic(dickey) > 0 Then
    
30.             l = l + 1
    
31.             result(l, 1) = Split(dickey, "|")(0)
    
32.             result(l, 2) = Split(dickey, "|")(1)
    
33.             result(l, 3) = dic(dickey)
    
34.         End If
    
35.     Next
    
36.     '判断是否有合乎条件的数据
    
37.     If l > 0 Then
    
38.         Range("f1").CurrentRegion.ClearContents
    
39.         Range("f2").Resize(l, 3) = result
    
40.         Range("f1").Resize(, 3) = Array("编号", "名称", "数量")
    
41.         MsgBox "提取完成"
    
42.     End If
    
43. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 提取数据2()
   
2.     Dim arr, Lastrow&, result()
   
3.     Dim key$, l&, i&, dickey
   
4.    
   
5.     Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
   
6.     arr = Range("a1:c" & Lastrow)
   
7.    
   
8.     Dim dic As Object
   
9.     Set dic = CreateObject("scripting.dictionary")
   
10.    
    
11.     For i = LBound(arr) + 1 To UBound(arr)
    
12.         key = arr(i, 1) & "|" & arr(i, 2)
    
13.         If dic.exists(key) Then
    
14.             dic(key) = dic(key) + arr(i, 3)
    
15.         Else
    
16.                dic(key) = arr(i, 3)
    
17.         End If
    
18.     Next
    
19.    
    
20.     ReDim result(1 To dic.Count, 1 To 3)
    
21.     For Each dickey In dic.keys
    
22.         If dic(dickey) > 0 Then
    
23.             l = l + 1
    
24.             result(l, 1) = Split(dickey, "|")(0)
    
25.             result(l, 2) = Split(dickey, "|")(1)
    
26.             result(l, 3) = dic(dickey)
    
27.         End If
    
28.     Next
    
29.     If l > 0 Then
    
30.         Range("f1").CurrentRegion.ClearContents
    
31.         Range("f2").Resize(l, 3) = result
    
32.         Range("f1").Resize(, 3) = Array("编号", "名称", "数量")
    
33.         MsgBox "提取完成"
    
34.     End If
    
35. End Sub

复制代码

hwc2ycy

1. Sub 提取数据()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : 提取数据
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/2/3
   
6. ' Purpose   : 字典+数组
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9.     Dim arr, Lastrow&, result()
   
10.     Dim key$, l&, i&, dickey
    
11. 
    
12.     '取最后一行数据所在行
    
13.     Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    
14.     '读取数据
    
15.     arr = Range("a1:c" & Lastrow)
    
16. 
    
17.     '字典
    
18.     Dim dic As Object
    
19.     Set dic = CreateObject("scripting.dictionary")
    
20.     '编号|名称做为关键字
    
21.     For i = LBound(arr) + 1 To UBound(arr)
    
22.         key = arr(i, 1) & "|" & arr(i, 2)
    
23.         dic(key) = dic(key) + arr(i, 3)
    
24.     Next
    
25.     '定义结果数组
    
26.     ReDim result(1 To dic.Count, 1 To 3)
    
27.     For Each dickey In dic.keys
    
28.         '统计数量为正值者写入结果数组
    
29.         If dic(dickey) > 0 Then
    
30.             l = l + 1
    
31.             result(l, 1) = Split(dickey, "|")(0)
    
32.             result(l, 2) = Split(dickey, "|")(1)
    
33.             result(l, 3) = dic(dickey)
    
34.         End If
    
35.     Next
    
36.     '判断是否有合乎条件的数据
    
37.     If l > 0 Then
    
38.         Range("f1").CurrentRegion.ClearContents
    
39.         Range("f2").Resize(l, 3) = result
    
40.         Range("f1").Resize(, 3) = Array("编号", "名称", "数量")
    
41.         MsgBox "提取完成"
    
42.     End If
    
43. End Sub

复制代码

JLxiangwei

203.zip (19.11 KB, 下载次数: 42)

2013-2-3 15:07 上传

点击文件名下载附件
烟花下手真快阿，一转眼一大篇VBA都写好了

蓝天一片云

hwc2ycy 发表于 2013-2-3 14:47

谢谢你提供代码！
换成下面的表格数据后代码如何修改？

蓝天一片云

JLxiangwei 发表于 2013-2-3 15:08
烟花下手真快阿，一转眼一大篇VBA都写好了

谢谢你提供代码！
5楼表格数据修改后代码如何改动？

蓝天一片云

JLxiangwei 发表于 2013-2-3 15:08
烟花下手真快阿，一转眼一大篇VBA都写好了

你提供的代码会将所有相同数据进行汇总，而我想提取不汇总的行数据。