Option Explicit
Sub NTKTNN()
Dim sArr(), I&, U&, f1#, f2#, h1#, h2#, iKeyF$, iKeyH$, ResF, ResH, X
Dim DicF As Object, DicH As Object, ArrH
Set DicF = CreateObject("Scripting.Dictionary")
Set DicH = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
sArr = .Range("A2:K" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
U = UBound(sArr, 1)
ReDim ArrH(1 To U, 1 To 2)
ReDim ResF(1 To U)
ReDim ResH(1 To U)
For I = 1 To U
iKeyF = Trim(sArr(I, 2)) & Trim(sArr(I, 3))
iKeyH = Trim(sArr(I, 1)) & Trim(sArr(I, 2))
If Not DicF.exists(iKeyF) Then
DicF.Add iKeyF, sArr(I, 5)
Else
ArrH(I, 1) = DicF.Item(iKeyF)
DicF.Item(iKeyF) = DicF.Item(iKeyF) + sArr(I, 5)
End If
If Not DicH.exists(iKeyH) Then
DicH.Add iKeyH, Array(sArr(I, 5), sArr(I, 8))
Else
ArrH(I, 2) = DicH.Item(iKeyH)(1)
X = DicH.Item(iKeyH)
X(0) = DicH.Item(iKeyH)(0) + sArr(I, 5)
X(1) = DicH.Item(iKeyH)(1) + sArr(I, 8)
DicH.Item(iKeyH) = X
End If
Next
For I = 1 To U
iKeyF = Trim(sArr(I, 2)) & Trim(sArr(I, 3))
iKeyH = Trim(sArr(I, 1)) & Trim(sArr(I, 2))
f1 = DicF.Item(iKeyF)
f2 = ArrH(I, 1)
h1 = DicH.Item(iKeyH)(0)
h2 = ArrH(I, 2)
If InStr(1, sArr(I, 4), "Pipes", 1) Then
ResF(I) = sArr(I, 7) * sArr(I, 5) / f1
ResH(I) = sArr(I, 9) * sArr(I, 5) / h1
Else
If sArr(I, 7) - f2 < 0 Then
ResF(I) = 0
ElseIf sArr(I, 7) - f2 >= sArr(I, 5) Then
ResF(I) = sArr(I, 5)
Else
ResF(I) = sArr(I, 7) - f2
End If
If sArr(I, 9) - h2 < 0 Then
ResH(I) = 0
ElseIf sArr(I, 9) - h2 >= sArr(I, 5) Then
ResH(I) = sArr(I, 5)
Else
ResH(I) = sArr(I, 9) - h2
End If
End If
Next
.Range("M2").Resize(U, 1) = Application.Transpose(ResF)
.Range("N2").Resize(U, 1) = Application.Transpose(ResH)
End With
End Sub
