|
Sub test()
Dim arrData, arrResult, dic As Object, d As Object
Dim x&, irow&, i&, n&, j%, str$, m$, s1#, s2#, ss$
Set dic = CreateObject("Scripting.Dictionary")
Set d = CreateObject("Scripting.Dictionary")
With Sheet6
irow = .Range("x" & Rows.Count).End(xlUp).Row
arrData = .Range("x3:aa" & irow).Value
For i = 1 To UBound(arrData)
dic(arrData(i, 1) & "," & arrData(i, 2) & "," & arrData(i, 3)) = arrData(i, 4)
dic(arrData(i, 1) & "," & arrData(i, 3)) = arrData(i, 4)
Next i
End With
With Sheet3
irow = .Range("d" & Rows.Count).End(xlUp).Row
arrData = .Range("a3:t" & irow).Value
ReDim arrResult(1 To UBound(arrData), 1 To 17)
End With
For i = 2 To UBound(arrData)
If arrData(i, 1) = "" Then
arrData(i, 1) = arrData(i - 1, 1)
arrData(i, 2) = arrData(i - 1, 2)
arrData(i, 3) = arrData(i - 1, 3)
End If
If arrData(i, 13) <> "" Then
str = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 4) & arrData(i, 5)
If Not d.exists(str) Then
n = n + 1
d(str) = n
For j = 1 To 5
arrResult(n, j) = arrData(i, j)
Next j
If Not VBA.IsNumeric(Right(arrData(i, 13), 1)) Then
arrResult(n, 17) = Right(arrData(i, 13), 1)
End If
End If
x = d(str)
m = Right(arrData(i, 13), 1)
If VBA.IsNumeric(m) Then m = ""
arrResult(x, 6) = arrResult(x, 6) + Val(Replace(arrData(i, 13), m, ""))
ss = arrData(i, 1) & arrData(i, 2) & arrData(i, 3) & arrData(i, 4)
If Not d.exists(ss) Then
d(ss) = d(str)
End If
x = d(ss)
arrResult(x, 8) = arrResult(x, 8) + arrData(i, 14)
arrResult(x, 10) = arrResult(x, 10) + arrData(i, 15)
End If
Next i
For i = 1 To n
str = arrResult(i, 3) & "," & arrResult(i, 4) & "," & arrResult(i, 5)
If dic.exists(str) Then arrResult(i, 7) = dic(str)
If arrResult(i, 8) <> 0 Then
str = arrResult(i, 3) & "," & arrData(1, 14)
If dic.exists(str) Then arrResult(i, 9) = dic(str)
s1 = arrResult(i, 9) * arrResult(i, 8)
End If
If arrResult(i, 10) <> 0 Then
str = arrResult(i, 3) & "," & arrData(1, 15)
If dic.exists(str) Then arrResult(i, 11) = dic(str)
s2 = arrResult(i, 10) * arrResult(i, 11)
End If
arrResult(i, 12) = arrResult(i, 6) * arrResult(i, 7) + s1 + s2
s1 = 0: s2 = 0
If arrResult(i, 17) = "m" Then
arrResult(i, 6) = Format(arrResult(i, 6), "0.00") & arrResult(i, 17)
Else
arrResult(i, 6) = Format(arrResult(i, 6), "0.0000") & arrResult(i, 17)
End If
Next i
With Sheet5
irow = .Range("a" & Rows.Count).End(xlUp).Row
If irow > 2 Then Range("a3:l" & irow).ClearContents
.Range("a3").Resize(n, 12) = arrResult
End With
End Sub
|
评分
-
查看全部评分
|