Return to Question

Thanks to zak for some great advice on this previous question. This is a follow up question:

Thanks to zak for some great advice on this previous question. This is a follow up question:

Sub TransferAndSumElements()
 Dim wb As Workbook
 Dim ws1 As Worksheet
 Dim ws2 As Worksheet
 
 Set wb = ActiveWorkbook
 Set ws1 = Sheets("Raw data")
 Set ws2 = Sheets("Summary")
 
 '##############
 ' Copy / Paste first row
 '##############
 ws1.Range("A1:B1").Copy _
 Destination:=ws2.Range("A1")
 
 '##############
 ' Set Item names in summary
 '##############
 With ws2
 .Range("A2").FormulaR1C1 = "Knife"
 .Range("A3").FormulaR1C1 = "Fork"
 .Range("A4").FormulaR1C1 = "Spoon"
 .Range("A5").FormulaR1C1 = "Spork"
 .Range("A6").FormulaR1C1 = "Bowl"
 End With
 
 
 '##############
 ' Find Elements and Sum
 '##############
 Dim s As Long ' Sum of elements for each Item
 Dim str As String ' String in first column in "Summary" (Knife, Fork ...)
 Dim cellstr As String ' String in first column in "Raw data" (To be searched through)
 Dim DataRange As Range ' All rows in sheet 1 ("Raw data")
 
 Dim cellA As Range  ' Used to find cellstr = cellA.Value
 Dim cellB As Range ' Used to increment s = s + cellB.Value
  ws1.Select ' Select first worksheet ("This worksheet")
 LastRow = ws1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
 Set DataRange = Range("A1:A" & LastRow)
 For i = 1 To 5 ' Iterate through Knife, Fork .. in "Summary"...
 str = ws2.Cells(i + 1, 1).Value ' Extract names
 s = 0 ' Initialize sum
 
 For r = 1 To LastRow
 Set cellA = ws1.Range("A" & r, "A" & r)
 cellstr = cellA.Value
 If InStr(cellstr, str) > 0 Then
 Set cellB = ws1.Range("B" & r, "B" & r)
 s = s + cellB.Value
 End If
 Next r
 ws2.Cells(i + 1, 2).FormulaR1C1 = s
 Next i
ws2.Activate
End Sub

Sub TransferAndSumElements()
 Dim wb As Workbook
 Dim ws1 As Worksheet
 Dim ws2 As Worksheet
 
 Set wb = ActiveWorkbook
 Set ws1 = Sheets("Raw data")
 Set ws2 = Sheets("Summary")
 
 '##############
 ' Copy / Paste first row
 '##############
 ws1.Range("A1:B1").Copy _
 Destination:=ws2.Range("A1")
 
 '##############
 ' Set Item names in summary
 '##############
 With ws2
 .Range("A2").FormulaR1C1 = "Knife"
 .Range("A3").FormulaR1C1 = "Fork"
 .Range("A4").FormulaR1C1 = "Spoon"
 .Range("A5").FormulaR1C1 = "Spork"
 .Range("A6").FormulaR1C1 = "Bowl"
 End With
 
 
 '##############
 ' Find Elements and Sum
 '##############
 Dim s As Long ' Sum of elements for each Item
 Dim str As String ' String in first column in "Summary" (Knife, Fork ...)
 Dim cellstr As String ' String in first column in "Raw data" (To be searched through)
 Dim DataRange As Range ' All rows in sheet 1 ("Raw data")
 
 ws1.Select ' Select first worksheet ("This worksheet")
 LastRow = ws1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
 Set DataRange = Range("A1:A" & LastRow)
 For i = 1 To 5 ' Iterate through Knife, Fork .. in "Summary"...
 str = ws2.Cells(i + 1, 1).Value ' Extract names
 s = 0 ' Initialize sum
 
 For r = 1 To LastRow
 cellstr = ws1.Range("A" & r, "A" & r).Value
 If InStr(cellstr, str) > 0 Then
 s = s + ws1.Range("B" & r, "B" & r).Value
 End If
 Next r
 ws2.Cells(i + 1, 2).FormulaR1C1 = s
 Next i
ws2.Activate
End Sub