Excel精英培训网

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

[已解决]如何计算不重复的数据

[复制链接]
发表于 2013-1-26 10:21 | 显示全部楼层 |阅读模式
如何计算不重复的数据
最佳答案
2013-1-26 14:42
  1. Sub 提取数据()
  2. '---------------------------------------------------------------------------------------
  3. ' Procedure : 提取数据
  4. ' Author    : hwc2ycy
  5. ' Date      : 2013/1/26
  6. ' Purpose   :字典+数组解法(下棋法)
  7. '---------------------------------------------------------------------------------------
  8. '
  9.     Dim irow&

  10.     '源活sheet1,防止过行时活动工作表不是sheet1
  11.     '取得最后数据所在行,如有数据则先清空原有数据
  12.     Worksheets("sheet1").Activate
  13.     irow = Cells(Rows.Count, "u").End(xlUp).Row
  14.     If irow > 1 Then
  15.         Range("u2:z" & irow).ClearContents
  16.     End If


  17.     '读取 记录明细  工作表数据到数组arr
  18.     Dim datasht$
  19.     datasht = "记录明细"
  20.     With Worksheets(datasht)
  21.         irow = .Cells(Rows.Count, 1).End(xlUp).Row
  22.         If irow > 1 Then
  23.             arr = .Range("a1:i" & irow)
  24.         Else
  25.             MsgBox datasht & " 工作表 数据出错"
  26.             Exit Sub
  27.         End If
  28.     End With

  29.     'sn为要查询的编号,读取并判断
  30.     Dim sn$
  31.     sn = [s1]
  32.     If Len(sn) = 0 Then
  33.         MsgBox "请在 S1 单元格输入要查询的编号"
  34.         Exit Sub
  35.     End If

  36.     'i行坐标,j列坐标
  37.     'arrResult为结果数组
  38.     'key为 ERP|存货名称|规格|单位|储位 列连接而成,作为字典关键字
  39.     Dim i&, j&
  40.     Dim arrResult()
  41.     Dim key$
  42.     ReDim arrResult(1 To UBound(arr), 1 To 6)

  43.     '字典对象
  44.     Dim dic As Object
  45.     Set dic = CreateObject("scripting.dictionary")

  46.     'InOut为入库和出库总和
  47.     'iRecord为当前统计出来的记录总数
  48.     'iPos指标答合要求的数据在结果数组中的存储位置
  49.     'sArr指示要获取的相关数据在arr中的列坐标
  50.     'key和iRecord配对存入字典,进行查询
  51.     Dim InOut&, iRecord&, iPos&
  52.     Dim sArr
  53.     sArr = Array(6, 7, 8, 9, 5)
  54.     For i = LBound(arr) To UBound(arr)
  55.         '先检测编号是否符合要求
  56.         If arr(i, 6) = sn Then
  57.             '连接相关数据,生成key
  58.             key = arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 8) & "|" & arr(i, 9) & "|" & arr(i, 5)
  59.             '统计入库和出库
  60.             InOut = arr(i, 3) + arr(i, 4) * -1
  61.             '检测Key是否在字典中
  62.             If dic.exists(key) Then
  63.                 '取得在数组中的行坐标
  64.                 iPos = dic(key)
  65.                 '数据累加
  66.                 arrResult(iPos, 6) = arrResult(iPos, 6) + InOut
  67.             Else
  68.                 '记录数加1
  69.                 iRecord = iRecord + 1
  70.                 For j = LBound(arrResult, 2) To UBound(arrResult, 2) - 1
  71.                     '写入相关列数据
  72.                     arrResult(iRecord, j) = arr(i, sArr(j - 1))
  73.                 Next
  74.                 '写入汇总数据
  75.                 arrResult(iRecord, 6) = InOut
  76.                 'key和irecord写入字典
  77.                 dic(key) = iRecord
  78.             End If
  79.         End If
  80.     Next
  81.     '判断是否有查找到符合要求的数据
  82.     If iRecord Then
  83.         Range("u2").Resize(iRecord, 6) = arrResult
  84.     Else
  85.         MsgBox "没有找到合适的数据,请确认编号"
  86.     End If
  87.     Set dic = Nothing
  88. End Sub
复制代码

book155.rar

48.03 KB, 下载次数: 44

发表于 2013-1-26 14:32 | 显示全部楼层
  1. Sub 提取数据()
  2.     Dim irow&
  3.     Worksheets("sheet1").Activate
  4.     irow = Cells(Rows.Count, "u").End(xlUp).Row
  5.     If irow > 1 Then
  6.         Range("u2:z" & irow).ClearContents
  7.     End If
  8.    
  9.     Dim datasht$
  10.     datasht = "记录明细"
  11.     With Worksheets(datasht)
  12.         irow = .Cells(Rows.Count, 1).End(xlUp).Row
  13.         If irow > 1 Then
  14.             arr = .Range("a1:i" & irow)
  15.         Else
  16.             MsgBox datasht & " 工作表 数据出错"
  17.             Exit Sub
  18.         End If
  19.         
  20.     End With
  21.    
  22.     Dim sn$
  23.     sn = [s1]
  24.     If Len(sn) = 0 Then
  25.         MsgBox "请在 S1 单元格输入要查询的编号"
  26.         Exit Sub
  27.     End If
  28.    
  29.     Dim i&, j&
  30.     Dim arrResult()
  31.     Dim key$
  32.     ReDim arrResult(1 To UBound(arr), 1 To 6)
  33.    
  34.     Dim dic As Object
  35.     Set dic = CreateObject("scripting.dictionary")
  36.     Dim InOut&, iRecord&, iPos&
  37.     Dim sArr
  38.     sArr = Array(6, 7, 8, 9, 5)
  39.     For i = LBound(arr) To UBound(arr)
  40.         If arr(i, 6) = sn Then
  41.             key = arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 8) & "|" & arr(i, 9) & "|" & arr(i, 5)
  42.             InOut = arr(i, 3) + arr(i, 4) * -1
  43.             If dic.exists(key) Then
  44.                 iPos = dic(key)
  45.                 arrResult(iPos, 6) = arrResult(iPos, 6) + InOut
  46.             Else
  47.                 iRecord = iRecord + 1
  48.                 For j = LBound(arrResult, 2) To UBound(arrResult, 2) - 1
  49.                     arrResult(iRecord, j) = arr(i, sArr(j - 1))
  50.                 Next
  51.                 arrResult(iRecord, 6) = InOut
  52.                 dic(key) = iRecord
  53.             End If
  54.         End If
  55.     Next
  56.     If iRecord Then
  57.         Range("u2").Resize(iRecord, 6) = arrResult
  58.     Else
  59.         MsgBox "没有找到合适的数据,请确认编号"
  60.     End If
  61. End Sub
复制代码
回复

使用道具 举报

发表于 2013-1-26 14:42 | 显示全部楼层    本楼为最佳答案   
  1. Sub 提取数据()
  2. '---------------------------------------------------------------------------------------
  3. ' Procedure : 提取数据
  4. ' Author    : hwc2ycy
  5. ' Date      : 2013/1/26
  6. ' Purpose   :字典+数组解法(下棋法)
  7. '---------------------------------------------------------------------------------------
  8. '
  9.     Dim irow&

  10.     '源活sheet1,防止过行时活动工作表不是sheet1
  11.     '取得最后数据所在行,如有数据则先清空原有数据
  12.     Worksheets("sheet1").Activate
  13.     irow = Cells(Rows.Count, "u").End(xlUp).Row
  14.     If irow > 1 Then
  15.         Range("u2:z" & irow).ClearContents
  16.     End If


  17.     '读取 记录明细  工作表数据到数组arr
  18.     Dim datasht$
  19.     datasht = "记录明细"
  20.     With Worksheets(datasht)
  21.         irow = .Cells(Rows.Count, 1).End(xlUp).Row
  22.         If irow > 1 Then
  23.             arr = .Range("a1:i" & irow)
  24.         Else
  25.             MsgBox datasht & " 工作表 数据出错"
  26.             Exit Sub
  27.         End If
  28.     End With

  29.     'sn为要查询的编号,读取并判断
  30.     Dim sn$
  31.     sn = [s1]
  32.     If Len(sn) = 0 Then
  33.         MsgBox "请在 S1 单元格输入要查询的编号"
  34.         Exit Sub
  35.     End If

  36.     'i行坐标,j列坐标
  37.     'arrResult为结果数组
  38.     'key为 ERP|存货名称|规格|单位|储位 列连接而成,作为字典关键字
  39.     Dim i&, j&
  40.     Dim arrResult()
  41.     Dim key$
  42.     ReDim arrResult(1 To UBound(arr), 1 To 6)

  43.     '字典对象
  44.     Dim dic As Object
  45.     Set dic = CreateObject("scripting.dictionary")

  46.     'InOut为入库和出库总和
  47.     'iRecord为当前统计出来的记录总数
  48.     'iPos指标答合要求的数据在结果数组中的存储位置
  49.     'sArr指示要获取的相关数据在arr中的列坐标
  50.     'key和iRecord配对存入字典,进行查询
  51.     Dim InOut&, iRecord&, iPos&
  52.     Dim sArr
  53.     sArr = Array(6, 7, 8, 9, 5)
  54.     For i = LBound(arr) To UBound(arr)
  55.         '先检测编号是否符合要求
  56.         If arr(i, 6) = sn Then
  57.             '连接相关数据,生成key
  58.             key = arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 8) & "|" & arr(i, 9) & "|" & arr(i, 5)
  59.             '统计入库和出库
  60.             InOut = arr(i, 3) + arr(i, 4) * -1
  61.             '检测Key是否在字典中
  62.             If dic.exists(key) Then
  63.                 '取得在数组中的行坐标
  64.                 iPos = dic(key)
  65.                 '数据累加
  66.                 arrResult(iPos, 6) = arrResult(iPos, 6) + InOut
  67.             Else
  68.                 '记录数加1
  69.                 iRecord = iRecord + 1
  70.                 For j = LBound(arrResult, 2) To UBound(arrResult, 2) - 1
  71.                     '写入相关列数据
  72.                     arrResult(iRecord, j) = arr(i, sArr(j - 1))
  73.                 Next
  74.                 '写入汇总数据
  75.                 arrResult(iRecord, 6) = InOut
  76.                 'key和irecord写入字典
  77.                 dic(key) = iRecord
  78.             End If
  79.         End If
  80.     Next
  81.     '判断是否有查找到符合要求的数据
  82.     If iRecord Then
  83.         Range("u2").Resize(iRecord, 6) = arrResult
  84.     Else
  85.         MsgBox "没有找到合适的数据,请确认编号"
  86.     End If
  87.     Set dic = Nothing
  88. End Sub
复制代码
回复

使用道具 举报

发表于 2013-1-26 14:44 | 显示全部楼层
入库以正数表示,出库以负数表示。
回复

使用道具 举报

发表于 2013-1-26 19:52 | 显示全部楼层
  1. InOut = arr(i, 3) + arr(i, 4) * -1
复制代码
改成
  1. InOut = arr(i, 3) - arr(i, 4)
复制代码
回复

使用道具 举报

 楼主| 发表于 2013-1-27 17:33 | 显示全部楼层
非常感谢,问题已解决了
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 21:51 , Processed in 5.366232 second(s), 12 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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