Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each ws In Worksheets(Array("入库", "出库"))
With ws
r = .Cells(.Rows.Count, 1).End(xlUp).Row
If r > 1 Then
arr = .Range("a2:j" & r)
For i = 1 To UBound(arr)
xm = arr(i, 3) & "+" & arr(i, 5) & "+" & arr(i, 9)
If Not d.exists(xm) Then
ReDim brr(1 To 9)
For j = 1 To 7
brr(j) = arr(i, j + 2)
Next
Else
brr = d(xm)
End If
If ws.Name = "入库" Then
brr(8) = brr(8) + arr(i, 10)
Else
brr(8) = brr(8) - arr(i, 10)
End If
d(xm) = brr
Next
End If
End With
Next
With Worksheets("库存")
.UsedRange.Offset(1, 0).ClearContents
If d.Count > 0 Then
.Range("a2").Resize(d.Count, 9) = Application.Transpose(Application.Transpose(d.items))
End If
End With
End Sub
Dim r%, i% '定义变量
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary") '字典
For Each ws In Worksheets(Array("入库", "出库")) '循环
With ws
r = .Cells(.Rows.Count, 1).End(xlUp).Row
If r > 1 Then '判断
arr = .Range("a2:j" & r) '数组
For i = 1 To UBound(arr) '循环
xm = arr(i, 3) & "+" & arr(i, 5) & "+" & arr(i, 9) '加法计算
If Not d.exists(xm) Then '判断
ReDim brr(1 To 9) '重定义数组
For j = 1 To 7 '循环
brr(j) = arr(i, j + 2) '赋值
Next
Else
brr = d(xm)
End If
If ws.Name = "入库" Then '判断
brr(8) = brr(8) + arr(i, 10) '加法计算
Else
brr(8) = brr(8) - arr(i, 10) '计算
End If
d(xm) = brr
Next
End If
End With
Next
With Worksheets("库存")
.UsedRange.Offset(1, 0).ClearContents
If d.Count > 0 Then
.Range("a2").Resize(d.Count, 9) = Application.Transpose(Application.Transpose(d.items)) '将数据写入表格中
End If
End With
End Sub追问
能更详细说明一下吗？谢谢！
