Merging and adding rows

[corbie82]

Hi all


im one formula away from getting my spreadsheet to look and do everything it needs to do.


I have 2 tabs old system and new system and a formula that copies all the data over and sorts them in a third tab. In the 3rd tab in column A is their name. Everybody should have 2 entries in the 3rd tab.
The data on how many calls they took is from column G to colomun U and the layout is identical from both the tabs. I need a vba formula that will combine the numbers from the row and then delete one of the entries like so.


This is what it looks like now

Name				Monday	Tuesday	Wednesday <tbody> </tbody>	Thursday <tbody> </tbody>	Friday <tbody> </tbody>	Saturday	Sunday
Mr old				0	0	0	0	0	0	0
Mr old				1	1	1	1	1	1	1
Mr new				2	2	2	2	2	2	2
Mr new				3	3	3	3	3	3	3
Mr Smith				4	4	4	4	4	4	4
Mr smith				5	5	5	5	5	5	5
Mr excel				5	5	5	5	5	5	5
Mr excel				6	6	6	6	6	6	6
This				is	how	i	would	like	it to	look
Mr old				1	1	1	1	1	1	1
Mr new				5	5	5	5	5	5	5
Mr Smith				9	9	9	9	9	9	9
Mr Excel				10	10	10	10	10	10	10

<tbody>
</tbody>

I get the feeling this is easy to do or its going to be a nightmare.

 

[JLGWhiz]

don't know if I got the columns right or not. But give it a try.

Sub summarize()
Dim ary() As Variant
    With Sheets("Sheet3") 'Edit sheet name
        .Range("A2", .Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , .Range("ZZ1"), True
        ary = Application.Transpose(.Range("ZZ2").Resize(.Range("ZZ1").CurrentRegion.Rows.Count - 1))
        .Range("ZZ1").CurrentRegion.Delete
        For i = LBound(ary) To UBound(ary)
            Set fn = .Range("A:A").Find(ary(i), , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    fAdr = fn.Address
                    For j = 7 To 21
                        fn.Offset(, j) = Application.SumIf(.Range("A:A"), ary(i), .Columns(j))
                    Next
                End If
                Set fn = .Range("A:A").FindNext(fn)
                If Not fn Is Nothing And fn.Address <> fAdr Then fn.EntireRow.Delete
        Next
    End With
End Sub

I strongly suggest you use a copy of your file and not the original.

 

[corbie82]

HI

Thanks for the code. It seems to do the removing part fine but it does do the adding bit right. Before i run the macro the sum total of the first column is 1263. After i run your program the total is 753. Just to recap it should combine the totals in the 2 rows and then remove the duplicate one. Any suggestions ?

 

[JLGWhiz]

I tweaked this a little. had it starting in the wrong column. see if this works better

Sub summarize()
Dim ary() As Variant
    With Sheets("Sheet3") 'Edit sheet name
        .Range("A2", .Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , .Range("ZZ1"), True
        ary = Application.Transpose(.Range("ZZ2").Resize(.Range("ZZ1").CurrentRegion.Rows.Count - 1))
        .Range("ZZ1").CurrentRegion.Delete
        For i = LBound(ary) To UBound(ary)
            Set fn = .Range("A:A").Find(ary(i), , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    fAdr = fn.Address
                    For j = 6 To 20
                        fn.Offset(, j) = Application.SumIf(.Range("A:A"), ary(i), .Columns(j + 1))
                    Next
                End If
                Set fn = .Range("A:A").FindNext(fn)
                If Not fn Is Nothing And fn.Address <> fAdr Then fn.EntireRow.Delete
        Next
    End With
End Sub

 

[corbie82]

Strange i get this error message now in the code although this code doesn't seem to have changed compared to the old one

I get run time error 5
invalid procedure call or agument


Set fn = .Range("A:A").FindNext(fn)
If Not fn Is Nothing And fn.Address <> fAdr Then fn.EntireRow.Delete
Next
End With
End Sub

 

[JLGWhiz]

Strange i get this error message now in the code although this code doesn't seem to have changed compared to the old one

I get run time error 5
invalid procedure call or agument


Set fn = .Range("A:A").FindNext(fn)
If Not fn Is Nothing And fn.Address <> fAdr Then fn.EntireRow.Delete
Next
End With
End Sub

I can't duplicate the error. The code runs as intended for me, without error. You can open the VBE, click anywhere inside the procedure and use function key F8 to step through the code line by line to see exactly where the code breaks down in relation to your data If you diminish the size of the VBE window so you can overlay it on the Excel worksheet while you step through, you see exactly what the code is doing and when. If you can pin point the place and condition that produces the error, I can probably fix it.

 

[JLGWhiz]

I thought it might be that you had more than two rows of the same name and that deleting one of the rows would temporarily kill the variable fn, but I added a third row with a duplicate name and it did not error on that either, so I still don't know what would cause the error. The code appears to be valid.

 

[JLGWhiz]

My test set up is in col A of sheet 3 a list of duplicate names (2 each). In Range G2:U7 I have numerical data, no blanks. When I run the code, it adds the values for each set of duplicates, deleting one of the rows as each one set is completed. Is that basically what you wanted to do with your sheet?