VBA sum data in certain columns based on common data

F

Forrtis

New Member
Joined
Apr 4, 2018
Messages
18
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:

[TABLE="width: 800"]
<tbody>[TR]
[TD][/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[TD]L[/TD]
[TD]M[/TD]
[TD]N[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Blank column[/TD]
[TD]Blank Column[/TD]
[TD]Blank Column[/TD]
[TD]Quantity[/TD]
[TD]Unit price[/TD]
[TD]Total[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]23[/TD]
[TD]X1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y1[/TD]
[TD]5[/TD]
[TD]L*M[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]41[/TD]
[TD]X2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y2[/TD]
[TD]15[/TD]
[TD]L*M[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]41[/TD]
[TD]X2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y3[/TD]
[TD]15[/TD]
[TD]L*M[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]23[/TD]
[TD]X1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y4[/TD]
[TD]5[/TD]
[TD]L*M[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]41[/TD]
[TD]X2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y5[/TD]
[TD]15[/TD]
[TD]L*M[/TD]
[/TR]
</tbody>[/TABLE]


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



[TABLE="width: 800"]
<tbody>[TR]
[TD][/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[TD]L[/TD]
[TD]M[/TD]
[TD]N[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Blank column[/TD]
[TD]Blank Column[/TD]
[TD]Blank Column[/TD]
[TD]Quantity[/TD]
[TD]Unit price[/TD]
[TD]Total[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]23[/TD]
[TD]X1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y1+Y4[/TD]
[TD]5[/TD]
[TD]L*M[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]41[/TD]
[TD]X2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y2+Y3+Y5[/TD]
[TD]15[/TD]
[TD]L*M[/TD]
[/TR]
</tbody>[/TABLE]

Any help would be greatly appreciated!
****** id="cke_pastebin" style="position: absolute; top: 573px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">[TABLE="width: 800"]
<tbody>[TR]
[TD]L*M[/TD]
[/TR]
</tbody>[/TABLE]
aNYa</body>
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
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?
 
Upvote 0
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.
Code: 
[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
 
Upvote 0
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:

jDvMLR8

jDvMLR8

jDvMLR8
34nlf6t.png
 
Upvote 0
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?
 
Upvote 0
Try this:-
Code: 
[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
 
Upvote 0
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?
 
Last edited:
Upvote 0
Try this for results starting "P1".
Code: 
[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
 
Upvote 0
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?
 
Upvote 0
Try this:-
NB:- You will need to change the Array headers in the code from "Blank Column " something else.!!
Code: 
[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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Dynamic data rollup by Row - non specific criteria
Replies
8
Views
342
Andy395
A
S
  • Question Question
Create New Sheet with Specific Name Based on Variable Cell
Replies
0
Views
219
SBExcel123
S
M
  • Question Question
VBA for different formulas to reduce the excel file
Replies
4
Views
207
MMM_84
M
B
  • Solved
SUMPRODUCT with FILTER Criteria
Replies
3
Views
342
Fluff
Fluff
R
  • Solved
How to independently sort multiple columns of this SEQUENCE output without effecting the positions of the columns and of the blanks?
2
Replies
15
Views
519
Rnkhch
R

Forum statistics

Threads
1,223,908
Messages
6,175,306
Members
452,633
Latest member
DougMo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top