|
- Sub 提取数据2()
- '---------------------------------------------------------------------------------------
- ' Procedure : 提取数据
- ' Author : hwc2ycy
- ' Date : 2013/2/3
- ' Purpose : 字典+数组
- '---------------------------------------------------------------------------------------
- '
- Dim arr, Lastrow&, result()
- Dim key$, l&, i&, dickey, j&
- '取最后一行数据所在行
- Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
- '读取数据
- arr = Range("a1:c" & Lastrow)
- '字典
- Dim dic As Object
- Set dic = CreateObject("scripting.dictionary")
- '编号|名称做为关键字
- ReDim result(1 To UBound(arr), 1 To 3)
- For i = LBound(arr) + 1 To UBound(arr)
- key = arr(i, 1) & "|" & arr(i, 2)
- If Not dic.exists(key) Then
- 'l = l + 1
- 'For j = LBound(arr, 1) To UBound(arr, 2)
- ' result(l, j) = arr(i, j)
- 'Next
- dic(key) = arr(i, 3)
- Else
- If dic(key) = 0 And arr(i, 3) > 0 Then
- l = l + 1
- For j = LBound(arr, 1) To UBound(arr, 2)
- result(l, j) = arr(i, j)
- Next
- Else
- If arr(i, 3) < 0 Then
- dic(key) = dic(key) + arr(i, 3)
- End If
- End If
- End If
- Next
- '判断是否有合乎条件的数据
- If l > 0 Then
- Range("f1").CurrentRegion.ClearContents
- Range("f2").Resize(l, 3) = result
- Range("f1").Resize(, 3) = Array("编号", "名称", "数量")
- MsgBox "提取完成"
- End If
- End Sub
复制代码 |
|