|
发表于 2011-12-28 18:15
|
显示全部楼层
本楼为最佳答案
- Sub justtest()
- Dim D As New Dictionary, Arr, i&, S$, Ar, Ph, Cj$, Sj, K&, ArrR(), j As Byte
- Ph = [a2]: Cj = [b2]: Sj = [c2]
- With Worksheets("合并汇总表")
- Arr = .Range("a3:m" & .Cells(.Rows.Count, 1).End(3).Row).Value
- For i = 1 To UBound(Arr)
- S = Arr(i, 1) & Arr(i, 6) & Arr(i, 7)
- If D.Exists(S) Then
- Ar = D(S)
- Ar(0) = Arr(i, 9) + CLng(Ar(0))
- Ar(1) = Arr(i, 13) + CLng(Ar(1))
- D(S) = Ar
- Else
- D.Add S, Array(CLng(Arr(i, 9)), CLng(Arr(i, 13)))
- End If
- Next
- End With
- With Worksheets("合并调用数据")
- Arr = .Range("a2:h" & .Cells(.Rows.Count, 1).End(3).Row).Value
- End With
- For i = 1 To UBound(Arr)
- If (Arr(i, 1) = Ph Or Len(Ph) = 0) And _
- (Arr(i, 6) = Cj Or Len(Cj) = 0) And _
- (Arr(i, 7) = Sj Or Len(Sj) = 0) Then
- K = K + 1: ReDim Preserve ArrR(1 To 12, 1 To K)
- For j = 1 To 8
- ArrR(j, K) = Arr(i, j)
- Next j
- S = Arr(i, 1) & Arr(i, 6) & Arr(i, 7)
- If D.Exists(S) Then
- ArrR(9, K) = D(S)(0)
- ArrR(11, K) = D(S)(1)
- Else
- ArrR(9, K) = 0
- ArrR(11, K) = 0
- End If
- ArrR(10, K) = ArrR(8, K) - ArrR(9, K)
- ArrR(12, K) = ArrR(8, K) - ArrR(11, K)
- End If
- Next
- Range("a4:l" & Rows.Count).ClearContents
- If K > 0 Then Range("a4").Resize(K, 12) = Application.Transpose(ArrR)
- Set D = Nothing
- End Sub
复制代码
是这样的效果吗?
见附件:
供应.rar
(20.81 KB, 下载次数: 39)
|
|