Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2906|回复: 6

[已解决]如何用VBA提取多行数据

[复制链接]
发表于 2013-2-3 15:47 | 显示全部楼层 |阅读模式
从A1:C15区域中提取数据.如果A列编号相同,C列数据正负抵消就不提取数据,只提取大于0的数据,不提取小于0的数据,结果见F1:H5区域
最佳答案
2013-2-3 16:13
  1. Sub 提取数据2()
  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, j&

  11.     '取最后一行数据所在行
  12.     Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
  13.     '读取数据
  14.     arr = Range("a1:c" & Lastrow)

  15.     '字典
  16.     Dim dic As Object
  17.     Set dic = CreateObject("scripting.dictionary")
  18.    
  19.     '编号|名称做为关键字
  20.     ReDim result(1 To UBound(arr), 1 To 3)
  21.    
  22.     For i = LBound(arr) + 1 To UBound(arr)
  23.         key = arr(i, 1) & "|" & arr(i, 2)
  24.         If Not dic.exists(key) Then
  25.             dic(key) = arr(i, 3)
  26.         Else
  27.             '判断汇总数量是否为0并且当前数据是否大于0
  28.             If dic(key) = 0 And arr(i, 3) > 0 Then
  29.                 l = l + 1
  30.                 For j = LBound(arr, 1) To UBound(arr, 2)
  31.                     result(l, j) = arr(i, j)
  32.                 Next
  33.             Else
  34.                 '更新汇总数量
  35.                 If arr(i, 3) < 0 Then
  36.                     dic(key) = dic(key) + arr(i, 3)
  37.                 End If
  38.             End If
  39.         End If
  40.     Next
  41.     '判断是否有合乎条件的数据
  42.     If l > 0 Then
  43.         Range("f1").CurrentRegion.ClearContents
  44.         Range("f2").Resize(l, 3) = result
  45.         Range("f1").Resize(, 3) = Array("编号", "名称", "数量")
  46.         MsgBox "提取完成"
  47.     End If
  48. End Sub
复制代码

2032.rar

5.18 KB, 下载次数: 45

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-2-3 15:53 | 显示全部楼层
这道题不是已经做过了嘛,不要重复发题。
回复

使用道具 举报

发表于 2013-2-3 15:54 | 显示全部楼层
回复

使用道具 举报

发表于 2013-2-3 15:58 | 显示全部楼层
有点不一样了,我再弄弄。
回复

使用道具 举报

发表于 2013-2-3 16:11 | 显示全部楼层
  1. Sub 提取数据2()
  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, j&

  11.     '取最后一行数据所在行
  12.     Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
  13.     '读取数据
  14.     arr = Range("a1:c" & Lastrow)

  15.     '字典
  16.     Dim dic As Object
  17.     Set dic = CreateObject("scripting.dictionary")
  18.     '编号|名称做为关键字

  19.     ReDim result(1 To UBound(arr), 1 To 3)


  20.     For i = LBound(arr) + 1 To UBound(arr)
  21.         key = arr(i, 1) & "|" & arr(i, 2)
  22.         If Not dic.exists(key) Then
  23.             'l = l + 1
  24.             'For j = LBound(arr, 1) To UBound(arr, 2)
  25.             '    result(l, j) = arr(i, j)
  26.             'Next
  27.             dic(key) = arr(i, 3)
  28.         Else
  29.             If dic(key) = 0 And arr(i, 3) > 0 Then
  30.                 l = l + 1
  31.                 For j = LBound(arr, 1) To UBound(arr, 2)
  32.                     result(l, j) = arr(i, j)
  33.                 Next
  34.             Else
  35.                 If arr(i, 3) < 0 Then
  36.                     dic(key) = dic(key) + arr(i, 3)
  37.                 End If
  38.             End If

  39.         End If
  40.     Next

  41.     '判断是否有合乎条件的数据
  42.     If l > 0 Then
  43.         Range("f1").CurrentRegion.ClearContents
  44.         Range("f2").Resize(l, 3) = result
  45.         Range("f1").Resize(, 3) = Array("编号", "名称", "数量")
  46.         MsgBox "提取完成"
  47.     End If
  48. End Sub
复制代码
回复

使用道具 举报

发表于 2013-2-3 16:13 | 显示全部楼层    本楼为最佳答案   
  1. Sub 提取数据2()
  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, j&

  11.     '取最后一行数据所在行
  12.     Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
  13.     '读取数据
  14.     arr = Range("a1:c" & Lastrow)

  15.     '字典
  16.     Dim dic As Object
  17.     Set dic = CreateObject("scripting.dictionary")
  18.    
  19.     '编号|名称做为关键字
  20.     ReDim result(1 To UBound(arr), 1 To 3)
  21.    
  22.     For i = LBound(arr) + 1 To UBound(arr)
  23.         key = arr(i, 1) & "|" & arr(i, 2)
  24.         If Not dic.exists(key) Then
  25.             dic(key) = arr(i, 3)
  26.         Else
  27.             '判断汇总数量是否为0并且当前数据是否大于0
  28.             If dic(key) = 0 And arr(i, 3) > 0 Then
  29.                 l = l + 1
  30.                 For j = LBound(arr, 1) To UBound(arr, 2)
  31.                     result(l, j) = arr(i, j)
  32.                 Next
  33.             Else
  34.                 '更新汇总数量
  35.                 If arr(i, 3) < 0 Then
  36.                     dic(key) = dic(key) + arr(i, 3)
  37.                 End If
  38.             End If
  39.         End If
  40.     Next
  41.     '判断是否有合乎条件的数据
  42.     If l > 0 Then
  43.         Range("f1").CurrentRegion.ClearContents
  44.         Range("f2").Resize(l, 3) = result
  45.         Range("f1").Resize(, 3) = Array("编号", "名称", "数量")
  46.         MsgBox "提取完成"
  47.     End If
  48. End Sub
复制代码
回复

使用道具 举报

发表于 2013-2-3 16:13 | 显示全部楼层
这个会要求你的数据要符合一定的规则。
否则统计出来的结果会有问题了。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 17:10 , Processed in 0.871724 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表