Duplicate Combine & Add Macro

[Stresbringer]

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.

 

[Stresbringer]

Hiya,


I have tried the new code but i cant seem to get it to work,
i keep getting a subscrupt out of range error, could someone tell me what im doing wrong ?

I can post some proper sample data with the desired results if it would be helpful. However, i feel its nearly right as the first code worked good except i had only antisipated 6 coloumns instead of 8.

Regards

Stres

 

[jindon]

Please make yourself clear, confusing...

1) What error are you getting? Compile error ? RunTime Error? Which line?

2) how many columns do you actually have? 6 or 8?

 

[Stresbringer]

Hiyas,

thanks for you swift reply, heres is the cose as i have it

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
            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

sorry if i have been unclear, When i run the macro i get a runtime error 9 Subscript Out of range.

There are 8 columns altogether below is some sample data from the actual sheet need the macro for.

Book1
	A	B	C	D	E	F	G	H	I	J
1	Payrollno	FullName	BasicPay	Overtime	TotalHours	Rate	TotalBonus	TotalPay
2	21095	Dave	89.55	0.00	14.90	6.01	0.00	89.55
3	21095	Dave	96.16	126.21	37.00	6.01	0.00	222.37
4	21095	Dave	90.15	0.00	15.00	6.01	15.71	105.86
5	21004	Jane	1,062.64	0.00	148.00	7.18	0.00	1,062.64
6	21063	Bob	395.40	0.00	60.00	6.59	64.05	459.45
7	21063	Bob	392.11	0.00	59.50	6.59	9.89	402.00
8
9		DesiredResult
10	21095	Dave	275.86	126.21	66.9	6.01	15.71	417.78
11	21004	Jane	1,062.64	0.00	148.00	7.18	0.00	1,062.64
12	21063	Bob	787.51	0.00	119.5	6.59	73.94	861.45
13
14
15
Sheet1

I hope this explains it

Thanks for all your help

 

[jindon]

If you have more than 5000 unique items as a result, it need to be altered
since transpose function only works with 5000 records,,,

Sorry, but I need to go off-line now.

I'll post the code tomorrow..

See ya

 

[jindon]

I just want to make clear that

Current code loop through all the worksheets except "summary" sheet in the workbook

Are you sure about it?

 

[Stresbringer]

Hiya jindon,

Thanks for taking the time to help me with this.

I am a little unsure on what the mean here

just want to make clear that

Current code loop through all the worksheets except "summary" sheet in the workbook

Are you sure about it?

There will only ever be 2 sheets within my workbook, sheet1 with all the data on it and the summary sheet used for the code.

Sheet 1 has roughly 1500 rows and 8 columns, each month i plan to copy & paste the information i get over to sheet 1 and run the macro .


I hope i have answered the question

Thanks

 

[Stresbringer]

ok ,

Today u retried the code, and fir some reason it worked (sort of)

the result on the summary page only game me 8 results for some reason (including the header)

the code is below,

 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

maybe i deleted someting i shouldnt have from the first code??

 

[jindon]

OK
Can you delete
2 lines after dic.comparemode = vbTextCompare that is:

For Each ws In Worksheets
    If ws.Name <> "summary" Then

and put following one line in that spot:

With Sheets("Sheet1")

then change next line as

a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(,8).Value

Delete following 2 lines before With Sheets("summary") that is:

      End If
Next

and enter[End With[/code] in that position

let's see if any difference....

 

[Stresbringer]

ok have changed the code to the one below:

 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
With Sheets("Sheet1")
        a = .Range("a1", .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
            End If
        Next i
End With
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

itv runs ok with no errors. However on the summary sheet i still only get 8 results (9 including the row header) =(

 

[jindon]

OOPs

Change

For i = 1 To UBound(a,1)

insteda of UBound(a,2)