+1 vote
in VBA by Beginner (20 points)

hi, everyone 

i have sheet1 contains data from a2 to g100  and have duplicate data. I need a macro to sum the duplicate data and delete them. At the same time, it should transfer data to sheet2 from a2 to g100.

by Expert (758 points)
Hello

Can you post sample of the workbook and some of the expected output?
by Beginner (20 points)

 

 

 

 

the result in the second image with macro code 

 

1 Answer

0 votes
by Beginner (35 points)

Put this into a new module.

Public Sub SumDuplicateData()

    Dim Srch As Range
    Sheet2.Range("A2:G100").Value = Empty
    
    For I = 2 To Sheet1.Range("F100").End(xlUp).Row
        Set Srch = Sheet2.Range("F2:F100").Find(Sheet1.Range("F" & I).Value)
        If Srch Is Nothing Then
            For j = 1 To 6
                Sheet2.Range(Cells(Sheet2.Range("F100").End(xlUp).Offset(1, 0).Row, j).Address).Value = Sheet1.Range(Cells(I, j).Address).Value
            Next j
            Sheet2.Range("G" & Sheet2.Range("F100").End(xlUp).Row).Value = Sheet2.Range("F100").End(xlUp).Row - 1
        Else
            For j = 1 To 3
                Sheet2.Range(Cells(Srch.Row, j).Address).Value = Sheet1.Range(Cells(I, j).Address).Value + Sheet2.Range(Cells(Srch.Row, j).Address).Value
            Next j
        End If
    Next I

End Sub

Reply if there are any problems.

by Beginner (35 points)

I learned something new, something good for you to know too for the future. Excel Arabic has columns which are reversed from Excel for all other languages. I saw the pictures above and thought column A was on the left to column G on the right. Excel Arabic is reversed with A on the right and G on the left. That was the confusion there. It is not well known, so for the future, when you take pictures of your screen try to include the column and row headings so that any confusion can be avoided. Sorry for that! Here is the updated macro. 

Option Explicit

Public Sub SumDuplicateData()

    Dim Srch, Srch2 As Range
    Dim I, J As Integer
    
    If Not Evaluate("ISREF('Sheet2'!A1)") Then
        Worksheets.Add.Name = "Sheet2"
        Worksheets("Sheet1").Range("A1:G1").Copy
        Worksheets("Sheet2").Range("A1").PasteSpecial
    End If
    Worksheets("Sheet2").Range("A2:G100").Value = Empty
    
    For I = 2 To Worksheets("Sheet1").Range("B100").End(xlUp).Row
        Set Srch = Worksheets("Sheet2").Range("B2:B100").Find(Worksheets("Sheet1").Range("B" & I).Value)
        Set Srch2 = Worksheets("Sheet2").Range("B100").End(xlUp)
        If Srch Is Nothing Then
            For J = 2 To 7
                Worksheets("Sheet2").Range(Cells(Srch2.Offset(1, 0).Row, J).Address).Value = Worksheets("Sheet1").Range(Cells(I, J).Address).Value
            Next J
            Worksheets("Sheet2").Range("A" & Srch2.Row).Offset(1, 0).Value = Srch2.Row - 1
        Else
            For J = 2 To 7
                If IsNumeric(Worksheets("Sheet1").Range(Cells(I, J).Address).Value) Then Worksheets("Sheet2").Range(Cells(Srch.Row, J).Address).Value = Worksheets("Sheet1").Range(Cells(I, J).Address).Value + Worksheets("Sheet2").Range(Cells(Srch.Row, J).Address).Value
            Next J
        End If
    Next I

End Sub

Hope it finally works for you.

by Beginner (20 points)

IT STILL PROBLEM WHEN TRANSFER DATA TO SHEET2   IT BEGINS FROM ROW35 NOT ROW 2 

 

 

by Beginner (20 points)

ok, i try your code with another workbook  it's perfectly work  but i have one thing  in sheet 2 the column  a  in item it doesen't work  numbering correctly 

 

it supposes from 1 not 0 

by Beginner (20 points)

 

ok, i found out  and adjusted the line code  from 

Worksheets("Sheet2").Range("A" & Srch2.Row).Offset(1, 0).Value = Srch2.Row - 1 

to this 

Worksheets("Sheet2").Range("A" & Srch2.Row).Offset(1, 0).Value = Srch2.Row

     honestly , i ppreciate your efforts  and i'm really sorry bacause  

i hvae more question  your code is perfect and work  well done runfunke 

by Beginner (35 points)
+1
You're welcome!

Welcome to wellsr Q&A
wellsr Q&A is the VBA and Python programming community that rewards you for learning how to code.

Getting Started
Register
VBA Cheat Sheets (On Sale Now)

Earn free prizes for asking VBA and Python questions and for answering questions asked by others in our community.

Looking for something else? Hire our professional VBA Help, instead.

What makes us different?
Our points system rewards you with a chance for free gifts based on the quality of your questions and answers. All you have to do is post and you could get rewarded, like these members:

Hightree $10 Amazon Gift Card
Thales1 $10 Amazon Gift Card
runfunke $10 Amazon Gift Card
coolag $10 Amazon Gift Card
Siew Hun $10 Amazon Gift Card

So, why don't you join us? It really is an encouraging way to motivate members in our VBA and Python community.

Register

For more programming tips visit the VBA Tutorials Blog and the Python Tutorials Blog.

...