|
如何计算不重复的数据
- Sub 提取数据()
- '---------------------------------------------------------------------------------------
- ' Procedure : 提取数据
- ' Author : hwc2ycy
- ' Date : 2013/1/26
- ' Purpose :字典+数组解法(下棋法)
- '---------------------------------------------------------------------------------------
- '
- Dim irow&
- '源活sheet1,防止过行时活动工作表不是sheet1
- '取得最后数据所在行,如有数据则先清空原有数据
- Worksheets("sheet1").Activate
- irow = Cells(Rows.Count, "u").End(xlUp).Row
- If irow > 1 Then
- Range("u2:z" & irow).ClearContents
- End If
- '读取 记录明细 工作表数据到数组arr
- Dim datasht$
- datasht = "记录明细"
- With Worksheets(datasht)
- irow = .Cells(Rows.Count, 1).End(xlUp).Row
- If irow > 1 Then
- arr = .Range("a1:i" & irow)
- Else
- MsgBox datasht & " 工作表 数据出错"
- Exit Sub
- End If
- End With
- 'sn为要查询的编号,读取并判断
- Dim sn$
- sn = [s1]
- If Len(sn) = 0 Then
- MsgBox "请在 S1 单元格输入要查询的编号"
- Exit Sub
- End If
- 'i行坐标,j列坐标
- 'arrResult为结果数组
- 'key为 ERP|存货名称|规格|单位|储位 列连接而成,作为字典关键字
- Dim i&, j&
- Dim arrResult()
- Dim key$
- ReDim arrResult(1 To UBound(arr), 1 To 6)
- '字典对象
- Dim dic As Object
- Set dic = CreateObject("scripting.dictionary")
- 'InOut为入库和出库总和
- 'iRecord为当前统计出来的记录总数
- 'iPos指标答合要求的数据在结果数组中的存储位置
- 'sArr指示要获取的相关数据在arr中的列坐标
- 'key和iRecord配对存入字典,进行查询
- Dim InOut&, iRecord&, iPos&
- Dim sArr
- sArr = Array(6, 7, 8, 9, 5)
- For i = LBound(arr) To UBound(arr)
- '先检测编号是否符合要求
- If arr(i, 6) = sn Then
- '连接相关数据,生成key
- key = arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 8) & "|" & arr(i, 9) & "|" & arr(i, 5)
- '统计入库和出库
- InOut = arr(i, 3) + arr(i, 4) * -1
- '检测Key是否在字典中
- If dic.exists(key) Then
- '取得在数组中的行坐标
- iPos = dic(key)
- '数据累加
- arrResult(iPos, 6) = arrResult(iPos, 6) + InOut
- Else
- '记录数加1
- iRecord = iRecord + 1
- For j = LBound(arrResult, 2) To UBound(arrResult, 2) - 1
- '写入相关列数据
- arrResult(iRecord, j) = arr(i, sArr(j - 1))
- Next
- '写入汇总数据
- arrResult(iRecord, 6) = InOut
- 'key和irecord写入字典
- dic(key) = iRecord
- End If
- End If
- Next
- '判断是否有查找到符合要求的数据
- If iRecord Then
- Range("u2").Resize(iRecord, 6) = arrResult
- Else
- MsgBox "没有找到合适的数据,请确认编号"
- End If
- Set dic = Nothing
- End Sub
复制代码
|
|