Sum values in cells based on a text in another cell

[lunatu]

Hi,

Im copying rows from workbook1 to workbook2 with the code below. Now I would like to modify the code so that if there is Group name in cell B, it would sum all those customers premium who are part of that group. For example like in the picture below.

Sub copysales()

Dim wb As New Workbook, rowToCopy As Integer
Dim lRow As Integer, nRow As Integer, rowno As Integer, colno As Integer

Set wb = Workbooks("Workbook2.xlsx")
lRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

nRow = wb.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1

rowToCopy = nRow
Application.ScreenUpdating = True
For rowno = 2 To lRow

If (ThisWorkbook.Sheets("Sheet1").Range("F" & rowno) = Won Then
For colno = 3 To 5
If ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno) > 0 Then
ThisWorkbook.Sheets("Sheet1").Range("A" & rowno).Copy wb.Sheets("Sales").Range("A" & rowToCopy) 'To copy customer name
ThisWorkbook.Sheets("Sheet1").Cells(1, colno).Copy wb.Sheets("Sales").Range("B" & rowToCopy) 'To copy product name
ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno).Copy
wb.Sheets("Sheet1").Range("C" & rowToCopy).PasteSpecial xlPasteValues 'To copy premium
rowToCopy = rowToCopy + 1

End If
Next
End If
Next
End Sub

Any ideas how to modify the code?

 

[lunatu]

In the results, why is the premium for Group 1, Product 2 1000 and not 2000 per the highlighted values below?

View attachment 55380

For Group1 it should be product2 2000 e

 

[Peter_SSs]

Assuming that Workbook2.xlsx is open and it has a sheet 'Sales' with no data, then give this a try from the source workbook.

Sub Collect_Sales()
  Dim d As Object
  Dim wsSales As Worksheet
  Dim a As Variant
  Dim i As Long
  Dim Cust As String
  
  Set d = CreateObject("Scripting.Dictionary")
  Set wsSales = Workbooks("Workbook2.xlsx").Sheets("Sales")
  With ThisWorkbook.Sheets("Sheet1")
    a = .Range("A1:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  For i = 2 To UBound(a)
    If a(i, 6) = "Won" Then
      Cust = IIf(IsEmpty(a(i, 2)), a(i, 1), "aaa" & a(i, 2))
      If a(i, 3) > 0 Then
        d(Cust & ";" & a(1, 3)) = d(Cust & ";" & a(1, 3)) + a(i, 3)
        d(Cust & ";zzzTotal") = d(Cust & ";zzzTotal") + a(i, 3)
      End If
      If a(i, 4) > 0 Then
        d(Cust & ";" & a(1, 4)) = d(Cust & ";" & a(1, 4)) + a(i, 4)
        d(Cust & ";zzzTotal") = d(Cust & ";zzzTotal") + a(i, 4)
      End If
    End If
  Next i
  With wsSales.Range("A2:C2").Resize(d.Count)
    .Rows(0).Value = Array("Customer Name", "Product", "Premium")
    With .Columns(1)
      .Value = Application.Transpose(d.Keys)
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
    End With
    .Columns(3).Value = Application.Transpose(d.Items)
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(2), Order2:=xlAscending, Header:=xlNo
    .Replace What:="aaa", Replacement:="", LookAt:=xlPart
    .Replace What:="zzz", Replacement:="", LookAt:=xlPart
  End With
End Sub

 

[lunatu]

Assuming that Workbook2.xlsx is open and it has a sheet 'Sales' with no data, then give this a try from the source workbook.

Sub Collect_Sales()
  Dim d As Object
  Dim wsSales As Worksheet
  Dim a As Variant
  Dim i As Long
  Dim Cust As String
 
  Set d = CreateObject("Scripting.Dictionary")
  Set wsSales = Workbooks("Workbook2.xlsx").Sheets("Sales")
  With ThisWorkbook.Sheets("Sheet1")
    a = .Range("A1:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  For i = 2 To UBound(a)
    If a(i, 6) = "Won" Then
      Cust = IIf(IsEmpty(a(i, 2)), a(i, 1), "aaa" & a(i, 2))
      If a(i, 3) > 0 Then
        d(Cust & ";" & a(1, 3)) = d(Cust & ";" & a(1, 3)) + a(i, 3)
        d(Cust & ";zzzTotal") = d(Cust & ";zzzTotal") + a(i, 3)
      End If
      If a(i, 4) > 0 Then
        d(Cust & ";" & a(1, 4)) = d(Cust & ";" & a(1, 4)) + a(i, 4)
        d(Cust & ";zzzTotal") = d(Cust & ";zzzTotal") + a(i, 4)
      End If
    End If
  Next i
  With wsSales.Range("A2:C2").Resize(d.Count)
    .Rows(0).Value = Array("Customer Name", "Product", "Premium")
    With .Columns(1)
      .Value = Application.Transpose(d.Keys)
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
    End With
    .Columns(3).Value = Application.Transpose(d.Items)
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(2), Order2:=xlAscending, Header:=xlNo
    .Replace What:="aaa", Replacement:="", LookAt:=xlPart
    .Replace What:="zzz", Replacement:="", LookAt:=xlPart
  End With
End Sub

This is working perfectly! Thanks a lot for your help and patience

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.

 

[lunatu]

You're welcome. Thanks for the follow-up.

Sorry to bother you one last time but as Im not familiar this code I need ja bit help still: I want the column F to copied as well from sheet1 to sheet Sales.

 

[Peter_SSs]

Sorry to bother you one last time but as Im not familiar this code I need ja bit help still: I want the column F to copied as well from sheet1 to sheet Sales.

For the Workbook 1 sample data in post #1, please show the Workbook 2 expected results so that I can see the expected values and layout that you want.

 

[lunatu]

For the Workbook 1 sample data in post #1, please show the Workbook 2 expected results so that I can see the expected values and layout that you want.

Here is an example picture of the workbook2. For customer part of some group the status is always the same, so there can not be different statutes in one group.

 

[Peter_SSs]

Here is an example picture of the workbook2.

Thanks.

Since the code only copies rows with "Won" status anyway, there is no need to "copy" the value from the original sheet. All we have to do is add a heading in column D and fill the column with "Won".
Just make these three changes in the last section of code.

  With wsSales.Range("A2:D2").Resize(d.Count)
    .Rows(0).Value = Array("Customer Name", "Product", "Premium", "Status")
    With .Columns(1)
      .Value = Application.Transpose(d.Keys)
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
    End With
    .Columns(3).Value = Application.Transpose(d.Items)
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(2), Order2:=xlAscending, Header:=xlNo
    .Replace What:="aaa", Replacement:="", LookAt:=xlPart
    .Replace What:="zzz", Replacement:="", LookAt:=xlPart
    .Columns(4).Value = "Won"
  End With

 

[lunatu]

Thanks.

Since the code only copies rows with "Won" status anyway, there is no need to "copy" the value from the original sheet. All we have to do is add a heading in column D and fill the column with "Won".
Just make these three changes in the last section of code.

  With wsSales.Range("A2:D2").Resize(d.Count)
    .Rows(0).Value = Array("Customer Name", "Product", "Premium", "Status")
    With .Columns(1)
      .Value = Application.Transpose(d.Keys)
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
    End With
    .Columns(3).Value = Application.Transpose(d.Items)
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(2), Order2:=xlAscending, Header:=xlNo
    .Replace What:="aaa", Replacement:="", LookAt:=xlPart
    .Replace What:="zzz", Replacement:="", LookAt:=xlPart
    .Columns(4).Value = "Won"
  End With

Perfect, thanks again!

 

[Peter_SSs]

Perfect, thanks again!

Cheers.