Macro code vba exel sum dublicate data and delete

- - Latest reply: ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
- Jul 19, 2019 at 12:17 PM
hi, everybody
i need help code vba exel i have data in sheet1 begening from cells a2:g100 many data are dublicateed
i would the sum dublicate and delet also the result shows in sheet2 from a2:g100 becarfull not dublicate
See more 

5 replies

Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294
0
Thank you
Post the code that you have worked on, as so we are careful to not duplicate what you have.

this is my code
Sub main()

With ActiveSheet '<== change "Fruit Stock" as per your actual sheet name

With Range("a1:G10")
Set r = .Resize(.Cells(.Rows.Count, .Columns.Count).End(xlUp).Row)

With r

.Copy
With .Offset(, .Columns.Count + 1)
.PasteSpecial xlPasteValues ' copy value and formats
.Columns(1).Offset(1).Resize(.Rows.Count - 1, 1).FormulaR1C1 = "=SUMIF(C" & r.Column & ",RC" & r.Column & ",C[-" & .Columns.Count + 1 & "])"
.Value = .Value
.RemoveDuplicates 1, xlYes
End With

End With

End With
End With
End Sub
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
I just recorded this macro:

Activesheet.range ("$ g $1:$ g $10").removeduplicates Columns:=1, Header:==xlNo
Range ("g1:g10").select
Selection.copy
Sheets.add after:=Activesheet
Activesheet.paste

give it a try
Respond to ac3mark
0
Thank you
you don't seem understand me what i ment sum the dublicated data in sheet1 then delete the dublicated data and transfer data to sheet2
for more explanation :
sheet1: a b c d e f g
item brand type origin purchase sales balance
1 1200R20 G580 THI 200 100 100
2 315/80R22.5 R184 JAP 500 50 450
3 1200R20 G580 THI 800 0 800
4 315/80R22.5 R184 JAP 1 100 50 1050
5 1200R20 G580 THI 1400 100 1300
the result to be in sheet2 :
a b c d e f g
item brand type origin purchase sales balance
1 1200R20 G580 THI 2400 200 2200
2 315/80R22.5 R184 JAP 600 100 500
it supposed transfer the data with formula from sheet1 to 2
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
You can always use:
Worksheetfunction.match (cells (somerow, somecolumn), range ("a1:a" & lastrowofcount), 0)
To trap the duplicates. Place them into an array. , cut the array, and paste it.
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
Also, is the first set of a data that is duplicated count as a duplicate, or not. Should it be in the totals and moved, or everyother occurance after the first?
Should be in the totals and moved
you'r maco it completely works but remain one thing the totals and removed
not count dublicate just i want add the values to others for dublicated data
Respond to abdelfatah
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294
0
Thank you
Alright, I am cleaning up some code, and will post it here for your review. Give me a couple of Hours!

Dim item(), itemrow(), itemcostA(), itemCostB(), itemCostC(), itemdup()
Dim arraycnt

Sub sbFindDuplicatesInColumn()
Dim lastrow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long

lastrow = findlastrow("Sheet1")
arraycnt = 0

For iCntr = 1 To lastrow

arraycnt = arraycnt + 1
MsgBox (arraycnt & " the counter")
ReDim Preserve item(arraycnt)
ReDim Preserve itemrow(arraycnt)
ReDim Preserve itemcostA(arraycnt)
ReDim Preserve itemCostB(arraycnt)
ReDim Preserve itemCostC(arraycnt)
ReDim Preserve itemdup(arraycnt)

itemdup(arraycnt) = 0

If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastrow), 0)
If iCntr <> matchFoundIndex Then
'Cells(iCntr, 2) = "Duplicate " & iCntr
getlen = UBound(item) - LBound(item) + 1
' MsgBox (getlen & " is the size of the array")
For t = 1 To getlen - 1
If Cells(arraycnt, 1).Value = item(t) Then
MsgBox ("this item would be added into " & item(t))
itemdup(t) = 1
Cells(arraycnt, 2).Value = "combined"
itemcostA(t) = itemcostA(t) + Cells(arraycnt, 3).Value
itemCostB(t) = itemCostB(t) + Cells(arraycnt, 4).Value
itemCostC(t) = itemCostC(t) + Cells(arraycnt, 5).Value
'MsgBox ("new total is: " & itemcostA(t) & " for array " & item(t))


End If

'itemdup(arraycnt) = 0

Next
Else

'add the item into the array

itemrow(arraycnt) = iCntr
item(arraycnt) = Cells(iCntr, 1).Value
itemcostA(arraycnt) = Cells(iCntr, 3).Value
itemCostB(arraycnt) = Cells(iCntr, 4).Value
itemCostC(arraycnt) = Cells(iCntr, 5).Value
'itemdup(arraycnt) = 0

'MsgBox (item(arraycnt) & " is set for arraycnt " & arraycnt)
End If
End If
Next
ThisWorkbook.Worksheets("Sheet2").Cells(1, 1).Value = "A"
ThisWorkbook.Worksheets("Sheet2").Cells(1, 3).Value = "C"
For Xcntr = 1 To lastrow

'MsgBox (itemdup(Xcntr) & " is set for " & item(Xcntr))
If itemdup(Xcntr) = 1 Then
'Cells(Xcntr, 2).Value = "*"

thisistherow = findlastrow("Sheet2") + 1

MsgBox ("this is the row: " & thisistherow)

MsgBox ("moving it to: " & thisistherow )

ThisWorkbook.Worksheets("Sheet2").Cells(thisistherow, 1).Value = item(Xcntr)
ThisWorkbook.Worksheets("Sheet2").Cells(thisistherow, 3).Value = itemcostA(Xcntr)

End If
Next
End Sub

Function findlastrow(whatsheet)
findlastrow = ThisWorkbook.Worksheets(whatsheet).Cells(Rows.Count, 1).End(xlUp).Row
End Function


And no, we have not deleted any duplicates, yet!!!!

Please do not post and tell me how it does not work, as it does, figure it out!
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
The sheet that you want to look for the duplicates on has to the active sheet. I did not place any error checking on this.

Perhaps, if you are not a programmer, then perform the analyst role, and manually perform the task through functions and spreadsheet design!! This can be performed by built in excel functions!!!
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
Are your sheets named sheet1 and sheet2? As I said, I am not going to produce a turn key solution. If I need to comment the code for you to understand, I will.
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
And yes, I know this is archaic code structure, but I wanted to expand the steps and not make it all one liners!
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
OK, here is the program with the delete. Make certain you change all particulars to fit your sheet. Make a copy of the sheet before you run the code.


Dim item(), itemrow(), itemcostA(), itemCostB(), itemCostC(), itemdup()
Dim arraycnt

Sub FindDuplicates()
Dim lastrow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long

lastrow = findlastrow("Sheet1")
arraycnt = 0

For iCntr = 1 To lastrow

arraycnt = arraycnt + 1
'MsgBox (arraycnt & " the counter")

'This expands the array to hold the same number of data elements as
'there are rows of parts

ReDim Preserve item(arraycnt)
ReDim Preserve itemrow(arraycnt)
ReDim Preserve itemcostA(arraycnt)
ReDim Preserve itemCostB(arraycnt)
ReDim Preserve itemCostC(arraycnt)
ReDim Preserve itemdup(arraycnt)

'here we set up each element with a boolean of whether it
'is duplicated or not. 0=no 1=yes
'all elements start as not duplicated, so we mark them 0
itemdup(arraycnt) = 0

If Cells(iCntr, 1) <> "" Then ' looks to see if Cell A rownumber has a value
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastrow), 0)
If iCntr <> matchFoundIndex Then

getlen = UBound(item) - LBound(item) + 1 'measures the size of the array and inits getlen
' MsgBox (getlen & " is the size of the array")
For t = 1 To getlen - 1
'we loop through the array to check if the element has already
'been loaded into the array
If Cells(arraycnt, 1).Value = item(t) Then 'this is the comparison of the array and the cell value
'MsgBox ("this item would be added into " & item(t))
'the below is the totaling of the parts totals.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Change the numbers in cells(arraycnt,X) to fit your sheet!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
itemcostA(t) = itemcostA(t) + Cells(arraycnt, 3).Value
itemCostB(t) = itemCostB(t) + Cells(arraycnt, 4).Value
itemCostC(t) = itemCostC(t) + Cells(arraycnt, 5).Value
'MsgBox ("new total is: " & itemcostA(t) & " for array " & item(t))

itemdup(t) = 1 'now we mark the original element that it has a duplicate
itemdup(arraycnt) = 1 'now we mark the new element that it is a duplicate
'Cells(t, 10).Value = 1
'Cells(arraycnt, 10).Value = 1
End If

Next
Else

'add the item into the array, as it has not been encountered yet, and is not
'in the array element index yet.

itemrow(arraycnt) = iCntr
item(arraycnt) = Cells(iCntr, 1).Value
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Change the numbers in cells(arraycnt,X) to fit your sheet!!!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
itemcostA(arraycnt) = Cells(iCntr, 3).Value
itemCostB(arraycnt) = Cells(iCntr, 4).Value
itemCostC(arraycnt) = Cells(iCntr, 5).Value

'MsgBox (item(arraycnt) & " is set for arraycnt " & arraycnt)
End If
End If
Next
'this sets up the sheet2 for headers. Change A-E to whatever headers you wish.
'make certain that the numbers in this setting matches the comparison above
with ThisWorkbook.Worksheets("Sheet2")
.Cells(1, 1).Value = "A"
.Cells(1, 3).Value = "C"
.Cells(1, 4).Value = "D"
.Cells(1, 5).Value = "E"
End With
'now we loop through the array to copy the array elements that are marked as a duplicate
'and move them to the second sheet
For Xcntr = 1 To lastrow
'MsgBox (itemdup(Xcntr) & " is set for " & item(Xcntr))
'MsgBox ("item duplicate marked: " & itemdup(Xcntr) & " cell is " & Cells(Xcntr, 10))
If itemdup(Xcntr) = 1 Then
'Cells(Xcntr, 2).Value = "*"
thisistherow = findlastrow("Sheet2") + 1
'MsgBox ("this is the row: " & thisistherow)
'MsgBox ("moving it to: " & thisistherow)
'this is the copy VVVVVVVVVVV
With ThisWorkbook.Worksheets("Sheet2")
.Cells(thisistherow, 1).Value = item(Xcntr)
.Cells(thisistherow, 3).Value = itemcostA(Xcntr)
End With


End If
Next

deleterow ' this runs the delete row function to remove all marked as a duplicate
End Sub

Function findlastrow(whatsheet)
findlastrow = ThisWorkbook.Worksheets(whatsheet).Cells(Rows.Count, 1).End(xlUp).Row
End Function


Function deleterow()
therow = 1
For tr = 1 To findlastrow("Sheet1")
thetest = itemdup(tr)
If thetest = 1 Then
ThisWorkbook.Worksheets("Sheet1").Rows(therow).EntireRow.Delete
Else
therow = therow + 1
End If
Next

End Function

more again thanks so much but the problem still stay it shwos the message "variable not defined " despite the names sheets are the same thing in your code also the columns the same thing i delete this expression "option explicit" i know this enforce declare variable but the problem is still continue i no know where is the mistake
Respond to ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294
0
Thank you
Look, I just opened a new workbook, set up two columns in A and C. Placed words in A and in C placed values next to them. Opened the developer tab. Inserted a new module. Came here, cut the code from above, pasted it into the module, and it ran. I can only encourage you to delete what ever module you have had, and start a new one, with only this code in it, as I NEVER HAD OPTION EXPLICIT in my code, so by you saying that you removed it, makes me wonder what else are you using?

Make certain Sheet1 is the active sheet when running the code. That is the only way that I can produce your error, is if sheet 2 has focus when it is run!!!!

Prior


After


Sheet 2 after run
ok i change my workbook the code does work but not completely
i put data in sheet 1 in cell a,b from cells 1 to 5 are repeated when i run code the data in sheet1 are gone the cells are empty and in sheet2 show letters a ,c, d ,e in column a,c,d,e and the data show but the value is 0 i fill data like you to columns
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
First thing, I do not know what to say. I have ran it on three different machines, and they all run without exception.

Second thing, you stated: " i fill data like you to columns", but then previously you had remarked "i put data in sheet 1 in cell a,b", WHICH IS CLEARLY WRONG!

I have no confidence you are deploying, or using this correctly. Once again, no issues here!
Respond to ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294
0
Thank you
Ok try this.....


one,,10
two,,10
three,,10
orange,,10
Five,,10
seven,,10
peas,,10
here,,10
four,,10
there,,10
five,,10
six,,10
banana,,10
peas,,10
six,,10
banana,,10


Take the above data set, cut and paste it into notepad. Now save it as sample.CSV (you will need to change the file type to all in order to save it as CSV!). Now, open your workbook with the code on it. Delete everything in SHEET1. Under the data tab, select GET DATA FROM TEXT/CSV. Find SAMPLE.CSV and select it. Now, under load, there is another option of load to, select cell A1 of Sheet1.

That should set the data up as expected to run.
here i do your steps the processing code changed a Little not more when i run the code in sheet1 stay the non repeating but the problem still continue in sheet2 it shows a,c,d,e in column a,c,d,e like this
columns:
a b c d e
A C D E
peas,,10 0
six,,10 0
banana,,10 0
ac3mark
Posts
12888
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
August 23, 2019
1294 -
Ok, so that code isn't formatting the result correctly? That is your job. You are the presentation, I am the engine!

Do you know where to change the headers in the code? I remarked it where to change them to whatever you wish.
Respond to ac3mark