|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("sheet2")
- rq1 = .Range("l1")
- rq2 = .Range("n1")
- End With
- With Worksheets("入库")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:h" & r)
- End With
- For i = 1 To UBound(arr)
- If arr(i, 1) >= rq1 And arr(i, 1) <= rq2 Then
- xm = arr(i, 3) & "+" & arr(i, 4)
- If Not d.exists(xm) Then
- ReDim brr(1 To 10)
- brr(1) = arr(i, 3)
- brr(2) = arr(i, 4)
- Else
- brr = d(xm)
- End If
- If arr(i, 2) = "入" Then
- brr(3) = brr(3) + arr(i, 6)
- brr(6) = brr(6) + arr(i, 8)
- Else
- brr(4) = brr(4) + arr(i, 6)
- brr(8) = brr(8) + arr(i, 8)
- End If
-
- d(xm) = brr
- End If
- Next
- m = 0
- ReDim crr(1 To d.Count, 1 To 10)
- For Each aa In d.keys
- brr = d(aa)
- brr(6) = Round(brr(6) / brr(3), 4)
- brr(8) = Round(brr(8) / brr(4), 4)
- m = m + 1
- For j = 1 To UBound(brr)
- crr(m, j) = brr(j)
- Next
- Next
- With Worksheets("sheet2")
- .UsedRange.Offset(1, 0).Clear
- .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
- End With
- End Sub
复制代码 |
|