|
有点小问题,改一下- Sub qq()
- Dim d As Object
- Dim r%, i%, aa, s$, j%
- Dim arr, brr, sht As Worksheet
- Set d = CreateObject("Scripting.Dictionary")
- For Each sht In Sheets(Array("进货", "销售"))
- With sht
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:d" & r)
- For i = 1 To UBound(arr)
- s = arr(i, 1) & arr(i, 2) & arr(i, 3)
- If Not d.Exists(s) Then
- ReDim brr(1 To 4)
- For j = 1 To 3
- brr(j) = arr(i, j)
- Next
- Else
- brr = d(s)
- End If
- brr(4) = brr(4) + IIf(sht.Name = "进货", 1, -1) * arr(i, 4)
- d(s) = brr
- Next
- End With
- Next
- For Each aa In d.keys
- If d(aa)(4) = 0 Then
- d.Remove (aa)
- End If
- Next
- If d.Count = 0 Then Sheet3.Cells.Clear: Exit Sub
- Sheet3.Cells.Clear
- Sheet1.[a1:d1].Copy Sheet3.[a1]
- Sheet3.Range("a2").Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.items))
- End Sub
复制代码 |
|