VBA sum data in certain columns based on common data

[Forrtis]

I have a very similar problem to the one in the link below:

https://www.mrexcel.com/forum/excel...plicate-rows-sum-values-certain-column-4.html

The only difference is the formatting of the data. The unsorted data comes in the following format:

	G	H	I	J	K	L	M	N
1	ID	Name	Blank column	Blank Column	Blank Column	Quantity	Unit price	Total
2	23	X1				Y1	5	L*M
3	41	X2				Y2	15	L*M
4	41	X2				Y3	15	L*M
5	23	X1				Y4	5	L*M
6	41	X2				Y5	15	L*M

<tbody>
</tbody>

The expected results is similar to the quoted thread, although there are slight differences:

• Columns L and N need to be summed
• Columns I, J and K need to stay blank
• Any number of rows may contain common data in cells belonging to columns G, H and M
  • Values in Column M may be common for two different ID's therefore this column cannot be used as a guide to consolidate the data
  • Either Column G or H can be used to look for common data and then the common rows need to be summed - only summing the columns indicated above
• There are ~100 different ID's to work with so the code needs to be able to handle this

	G	H	I	J	K	L	M	N
1	ID	Name	Blank column	Blank Column	Blank Column	Quantity	Unit price	Total
2	23	X1				Y1+Y4	5	L*M
3	41	X2				Y2+Y3+Y5	15	L*M

<tbody>
</tbody>

Any help would be greatly appreciated!
****** id="cke_pastebin" style="position: absolute; top: 573px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">

L*M

<tbody>
</tbody>

aNYa</body>

 

[Forrtis]

I've tried modifying the code provided in the linked thread with no success. I am guessing this would be the easiest way but I can't get it to work? Any tips on how to modify it?

 

[MickG]

Try this:-
NB:- I'm not quite sure what you expect the results to be in column "L,M & N" but if not correct please show example of expected results.

[COLOR="Navy"]Sub[/COLOR] MG18Dec20
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("G2", Range("G" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
        .Item(Dn.Value).Offset(, 5).Value = _
        .Item(Dn.Value).Offset(, 5).Value & " + " & Dn.Offset(, 5).Value
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Forrtis]

Thank you for you reply, I have just tried it and it is along the right lines but not quite there.
Columns G:K do what I would expect them to so that's great!

I would like column L to display the sum of Y's. At the moment it displays Y+Y1+Y2 or (5+3+4) and I want it to actually carry out the sum so it would display 12 instead of 5+3+4.
Please see example below, hopefully the image clarifies everything:

 

[Forrtis]

I am not sure why the image isn't being displayed, It was working fine yesterday.

I'll try to explain without the image:
- Column L displays the sum of cells in this column belonging to common rows
- Column M is unique to most ID's, although two ID's could have the same unit price
- Column N is the product of multiplying column L and M, or the sum of cells in this column belonging to common rows

Does this make more sense?

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG19Dec50
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("G2", Range("G" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
       [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
        .Item(Dn.Value).Offset(, 5).Value = _
        .Item(Dn.Value).Offset(, 5).Value + Dn.Offset(, 5).Value
        .Item(Dn.Value).Offset(, 7).Value = _
        .Item(Dn.Value).Offset(, 5).Value * Dn.Offset(, 6).Value
       [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Forrtis]

Thank you so much, it does everything I mentioned! However, there is other data in the other columns so not ideal that it deletes the entire rows. Is there a way to delete just the data in the columns that the code is working on (G:N) OR even better, does not delete any data at all just reprints the result in column "P" onward?

 

[MickG]

Try this for results starting "P1".

[COLOR="Navy"]Sub[/COLOR] MG19Dec26
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("G2", Range("G" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
ReDim Ray(1 To Rng.Count, 1 To 5)
c = 1
Ray(1, 1) = "ID": Ray(1, 2) = "Name": Ray(1, 3) = "Qty": Ray(1, 4) = "UnitPrice": Ray(1, 5) = "Total"
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        [COLOR="Navy"]For[/COLOR] Ac = 1 To 4
            col = IIf(Ac > 2, Ac + 2, Ac - 1)
            Ray(c, Ac) = Dn.Offset(, col)
        [COLOR="Navy"]Next[/COLOR] Ac
        Ray(c, 5) = Dn.Offset(, 5) * Dn.Offset(, 6)
        .Add Dn.Value, c
    [COLOR="Navy"]Else[/COLOR]
        Ray(.Item(Dn.Value), 3) = Ray(.Item(Dn.Value), 3) + Dn.Offset(, 5)
        Ray(.Item(Dn.Value), 5) = Ray(.Item(Dn.Value), 5) + Dn.Offset(, 5) * Dn.Offset(, 6)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Range("P1").Resize(c, 5)
    .Value = Ray
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Forrtis]

Nearly! The results are printed in the right place and no data is deleted but the blank columns in I J K are not replicated in the re-print?

 

[MickG]

Try this:-
NB:- You will need to change the Array headers in the code from "Blank Column " something else.!!

[COLOR="Navy"]Sub[/COLOR] MG19Dec06
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("G2", Range("G" & Rows.Count).End(xlUp))

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
ReDim Ray(1 To Rng.Count, 1 To 8)
c = 1

Ray(1, 1) = "ID": Ray(1, 2) = "Name": Ray(1, 3) = "Blank Column": Ray(1, 4) = "Blank Column"
 Ray(1, 5) = "Blank Column": Ray(1, 6) = "Qty": Ray(1, 7) = "UnitPrice": Ray(1, 8) = "Total"

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        [COLOR="Navy"]For[/COLOR] Ac = 1 To 7
            Ray(c, Ac) = Dn.Offset(, Ac - 1)
        [COLOR="Navy"]Next[/COLOR] Ac
        Ray(c, 8) = Dn.Offset(, 5) * Dn.Offset(, 6)
        .Add Dn.Value, c
    [COLOR="Navy"]Else[/COLOR]
        Ray(.Item(Dn.Value), 6) = Ray(.Item(Dn.Value), 6) + Dn.Offset(, 5)
        Ray(.Item(Dn.Value), 8) = Ray(.Item(Dn.Value), 8) + Dn.Offset(, 5) * Dn.Offset(, 6)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Range("P1").Resize(c, 8)
    .Value = Ray
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick