Duplicate Combine & Add Macro

Stresbringer · May 30, 2006

Hiya All,

I have done some searching and nothing i have come accross quite decribes what i need,.
i hope someone can help me to make some sort of formula or macro which will find duplicate rows and add them together and combine them.Its kind of hard to explain but i will try to show you in my sample data below

ID No Name C D E F
1489 Mike 10 12 100 7
1489 Mike 150 3 100 4
1489 Mike 35 17 100 3

7457 Joe 11 50 200 4
7457 Joe 4 1 200 5

1359 Sue 20 90 150 25
1359 Sue 30 4 150 10
1359 Sue 5 6 150 7

I would like a macro or a formula which will Find the duplicates in a sheet and Combine and add the values together for C, D and F ID Name and E should remain the same.

From the data above result i want to gets is:

ID No Name C D E F

1489 Mike 195 32 100 14

7457 Joe 15 51 200 9

1359 Sue 55 100 150 42

as can see C D and F have been added together but the id and name remain the same, there can be upto 5 duplicated per person so i need to be able to allow for this.

i hope this makes sence

A macro of somesort would save endless hours of work and would cut out much human error, i am new to Vba but i hear you can do pretty much anything with it and i hope someone can tell me if this is possible or not.

Thanks in advance.

CharlesH · May 30, 2006

Dup and combind

Hi,

The following code was created by jindon. I hope it was ok for me to modify it. All the cudo's go to jindon.
Copy and paste this to a module. Add a worksheet for "Summary"

Code:

Sub test()
''' Original code was by jindon MVP I modified it for this post.
'' Thanks to jindon '''
Dim dic As Object, ws As Worksheet, z As String, a, result()
Set dic = CreateObject("scripting.dictionary")
dic.comparemode = vbTextCompare
For Each ws In Worksheets
   If ws.Name <> "Summary" Then
      a = ws.Range("a1", ws.Range("a" & Rows.Count).End(xlUp)).Resize(, 6).Value
     For i = 1 To UBound(a, 1)
        z = a(i, 1) & ":" & a(i, 2)
        If Not dic.exists(z) Then
            n = n + 1
            ReDim Preserve result(1 To 6, 1 To n)
            result(1, n) = a(i, 1): result(2, n) = a(i, 2): result(3, n) = a(i, 3) _
                : result(4, n) = a(i, 4): result(5, n) = a(i, 5): result(6, n) = a(i, 6)
            dic.Add z, n
       Else
           result(3, dic(z)) = result(3, dic(z)) + a(i, 3)
           result(4, dic(z)) = result(4, dic(z)) + a(i, 4)
           result(5, dic(z)) = result(5, dic(z))
           result(6, dic(z)) = result(6, dic(z)) + a(i, 6)
       End If
     Next
  End If
Next
With Sheets("summary")
    .Cells.Clear
    .Range("a1").Resize(n, 6) = Application.Transpose(result)
End With
Set dic = Nothing: Erase a, result
End Sub

Note to jindon. If I errored by using this please let me know.

CharlesH

PS I learned alot from this code!

jindon · May 30, 2006

Chales

Well done.

You don't need just one line

result(5,dic(z))=result(5,dic(z))

CharlesH · May 30, 2006

Thanks for the lesson.

CharlesH

Stresbringer · May 31, 2006

Hi Guys,

Thank you this is working very well at the moment, although there are more coloumns than i first anticipated i was wondering if someone could ajuat the code for me to accomodate, ive had a look at it bit i dont know the first thing about VBA

now my sheet contains 8 coloumns instead i need coloumn A B & F to remain unchanged and the rest to add up like the code above does.

Is there anyone who could rewite the code for me ?

Thanks again

Stresbringer · Jun 1, 2006

Hi all just wondered if anyone know how to alter this code so it works with 8 coloumns instead of 6

jindon · Jun 1, 2006

Stresbringer,

I'm having difficulties with my PC, no copy/paste, no Excel
So I hope you understand what I try to say

change the line to
a=ws.range("a1",.range("a" & rows.count).end(xlup)).resize(,8).value

change lines to

redim preserve result(1 to 8,1 to n)
for ii=1 to ubound(a,2)
result(ii,n)=a(i,ii)
next
dic.add z,n

and delete
result(1,n)=a(i,1):......:result(6,n)=a(i,6)

change

Else
for ii=3 to 8
if ii<>6 then
result(ii,dic(z))=result(ii,dic(z))+a(i,ii)
end if
next

then delete
result(3,dic(z))=result(3,dic(z))+a)i,3)
.
.
.
result(6,dic(z))=result(6,dic(z))+a(i,6)

change

.range("a1").resize(n,ubound(a,2))=application.transpose(result)

Fazza · Jun 1, 2006

For an alternative solution without formula or VBA code, this is another good case for a query table.

I'll quickly explain the steps. Assuming the file has been saved and the data block has headers. Give the source data a defined name. Shortcut CTRL-F3.

Follow menu Data, Import External Data, New Database Qeury. Excel files for the data source. Select the workbook. When the defined name appears click the ">" to put all the columns in the query. Click next a few times (or enter any filters if appropriate. specify a sort order too) Select "View Data or edit query in Microsoft Query" and then FINISH.

When MS Query opens you'll see the results data set. You can click in a cell where you want a summation result for the column and then hit the upper case sigma (summation symbol) on the toolbar. Repeat for the other two summation formula. (If you hit it twice by mistake, keep hitting it and it will cycle back after average, count, min & max.)

Hit the "door" button to return data to Excel.

This is a quick "how to". This database functionality is simple and can be powerful.

HTH
Fazza

Stresbringer · Jun 16, 2006

Hiya,

Thanks for all your help with this, sorry i havent replied soon but my computers has been broken for a few weeks.

Jindon

I have tried to follow you instuctions and this is what i have :

Sub test()
''' Original code was by jindon MVP I modified it for this post.
'' Thanks to jindon '''
Dim dic As Object, ws As Worksheet, z As String, a, result()
Set dic = CreateObject("scripting.dictionary")
dic.comparemode = vbTextCompare
For Each ws In Worksheets
If ws.Name <> "Summary" Then
a = ws.Range("a1", ws.Range("a" & Rows.Count).End(xlUp)).Resize(, 8).Value
For i = 1 To UBound(a, 2)
z = a(i, 1) & ":" & a(i, 2)
If Not dic.exists(z) Then
n = n + 1
ReDim Preserve result(1 To 8, 1 To n)
For ii = 1 To UBound(a, 2)
result(ii, n) = a(i, ii)
Next
dic.Add z, n
Else
For ii = 3 To 8
If ii <> 6 Then
result(ii, dic(z)) = result(ii, dic(z)) + a(i, ii)
End If
Next
End If
Next
With Sheets("summary")
.Cells.Clear
.Range("a1").Resize(n, UBound(a, 2)) = Application.Transpose(result)
End With
Set dic = Nothing: Erase a, result
End Sub

I get an error message wich says: Compile Error : Block If without End If
and it Highlights the End sub part of the code

Please could some help me out with this and tell me where im going wrong?

Stres

CharlesH · Jun 16, 2006

Missing line

Hi,

Added missing line. Try this.

Code:

 Sub test()
''' Original code was by jindon MVP I modified it for this post.
'' Thanks to jindon '''
Dim dic As Object, ws As Worksheet, z As String, a, result()
Set dic = CreateObject("scripting.dictionary")
dic.comparemode = vbTextCompare
For Each ws In Worksheets
    If ws.Name <> "Summary" Then
        a = ws.Range("a1", ws.Range("a" & Rows.Count).End(xlUp)).Resize(, 8).Value
        For i = 1 To UBound(a, 2)
            z = a(i, 1) & ":" & a(i, 2)
            If Not dic.exists(z) Then
                n = n + 1
                ReDim Preserve result(1 To 8, 1 To n)
                For ii = 1 To UBound(a, 2)
                    result(ii, n) = a(i, ii)
                Next ii
                dic.Add z, n
            Else
                For ii = 3 To 8
                    If ii <> 6 Then
                        result(ii, dic(z)) = result(ii, dic(z)) + a(i, ii)
                    End If
                Next ii ''''' this was missing
            End If
        Next i
    End If
Next
With Sheets("summary")
.Cells.Clear
.Range("a1").Resize(n, UBound(a, 2)) = Application.Transpose(result)
End With
Set dic = Nothing: Erase a, result
End Sub

CharlesH

Duplicate Combine & Add Macro

Stresbringer

Board Regular

Excel Facts

CharlesH

Active Member

jindon

MrExcel MVP

CharlesH

Active Member

Stresbringer

Board Regular

Stresbringer

Board Regular

jindon

MrExcel MVP

Fazza

MrExcel MVP

Stresbringer

Board Regular

CharlesH

Active Member

Similar threads

Forum statistics

Share this page

Duplicate Combine & Add Macro

Board Regular

Excel Facts

Active Member

MrExcel MVP

Active Member

Board Regular

Board Regular

MrExcel MVP

MrExcel MVP

Board Regular

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock