See attached file where I added this macro taht does calculation as you need.
Macro requires you put on row 3 of 'Dyed Yarn' sheet arn to associate with row 5 to look for them in sheet 1.
Macro needs also the columns of the range where put toalizations, see in code:
'range where totalize
myRange = "b:al"
Macro will automatically starts when you switch from first shet to 'Dyed Yarn' sheet
Sub GetTotals()
Dim dpSh As Worksheet
Dim dySh As Worksheet
Dim dic As Object
Dim myRange As String, c
Dim myCount As String, myYarn As String
Dim myKey As String, lastRow As Long, r As Long
Dim elem As Variant
Dim myResult As Double, mySum As Double
On Error GoTo lblError
Set dpSh = ThisWorkbook.Sheets("daily production")
Set dySh = ThisWorkbook.Sheets("dyed yarn")
Set dic = CreateObject("scripting.dictionary")
'range where totalize
myRange = "b:al"
For Each c In Range(myRange).Columns
If dySh.Cells(3, c.Column) <> "" Then
myYarn = dySh.Cells(3, c.Column)
End If
myCount = dySh.Cells(5, c.Column)
myKey = myCount & "," & myYarn
dic.Add Item:="", key:=myKey
Next
lastRow = dpSh.Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
For r = 1 To lastRow
If Trim(dpSh.Cells(r, "d")) <> "" And Trim(dpSh.Cells(r, "e")) <> "" Then
myKey = dpSh.Cells(r, "d") & "," & dpSh.Cells(r, "e")
If dic.exists(myKey) Then
dic(myKey) = dic(myKey) & "+" & dpSh.Cells(r, "g")
End If
End If
Next r
For Each elem In dic.Keys
If dic(elem) <> "" Then
myResult = Evaluate(Replace(dic(elem), ",", "."))
mySum = mySum + myResult
dic(elem) = Mid(dic(elem), 2)
If InStr(dic(elem), "+") > 0 Then
dic(elem) = dic(elem) & "=" & myResult
End If
Else
dic(elem) = "0"
End If
Next elem
'put cells calculation
dySh.Cells(6, Range(myRange).Columns(1).Column).Resize(1, dic.Count) = dic.items
dySh.Cells(6, Range(myRange).Offset(, Range(myRange).Columns.Count).Column) = mySum
lblExit:
Set dpSh = Nothing
Set dySh = Nothing
Set dic = Nothing
Exit Sub
lblError:
Stop
Resume Next
End Sub
Private Sub Worksheet_Activate()
Call Me.GetTotals
End Sub
Regards,
Antonio
Bookmarks