PDA

View Full Version : Remove duplicates on three criteria



k0st4din
04-16-2014, 10:38 AM
Hello friends , I need your help a lot for a macro . My query is this: is there any possibility to delete rows if matches 3 criteria. If the code in column (J), and the number in column (G), and month ( no date ) from column (D) - coincide - then delete entire rows ( matches ) . The idea is to remove duplicates on three criteria .
They offered me a macro that shuffles names ranks and became a mishmash. Information will accumulate each month and this month we've removed duplicates (they will remain in place ) , the next month we put new information, and then the macro will check the new with the old and remove matches only the new information , and so n up to the end .
I really need your help and find a solution.
I beg of you help me .

SamT
04-16-2014, 12:49 PM
K0st4din,

I'm sorry, but I don't have a lot of time right now.

First record a macro to sort the table first by Number, then by Code then by Date, (all in one sort.)

Then adjust that macro find the last row in the date column

Then in the same macro

for r = LastRow to 2 step -1
If Cells(r, "G") = Cells(r-1, "G") And Cells(r, "d") = Cells (r-1, "D") And Cells(r, "J") = Cells (r-1, "J") Then
Rows(r).Delete
Next r

mancubus
04-16-2014, 02:51 PM
if you have office 2007+, you can use this:



Sub rem_dupl()
Worksheets("Sheet1").Cells(1).CurrentRegion.RemoveDuplicates Columns:=Array(10, 7, 4), Header:=xlYes
'Array(10, 7, 4): 10 = col J / 7 = col G / 4 = Col D
End Sub

k0st4din
04-16-2014, 08:26 PM
SamT
It gives me an error.
attached Images
11581
or do you mean I have another macro that adds to your macro - if so , it does not know how to go .
I only want to add : other suggestions of my macro removes duplicate rows but first invert all of the original and second - when I saved the file and open it next time to add information macro is not activated for the first time when it did previously delete . Here it is proposed macro ( as in it - he sought matches but not month and just a coincidence ) - the idea is that in the same month ( no dates) I have repeated names and codes, and does not delete them because the date is different
I'll be glad to discuss it and I will show the proposed macro


Sub Dublikati_SIM_K()
Dim sh As Worksheet, lr As Long
Set sh = Sheets(2) 'Edit Sheet name
lr = sh.Cells(Rows.Count, 11).End(xlUp).Row
sh.UsedRange.Sort sh.Range("K2"), xlAscending, Header:=xlYes
For i = lr To 2 Step -1
If sh.Cells(i, 11).Value = sh.Cells(i - 1, 11).Value And _
sh.Cells(i, 7).Value = sh.Cells(i - 1, 7).Value And _
sh.Cells(i, 4).Value = sh.Cells(i - 1, 4).Value Then
Cells(i, "A").Resize(, 24).Delete Shift:=xlUp
End If
Next
End Sub
Link to picture (http://prikachi.com/images/27/7268027e.jpg)

ashleyuk1984
04-17-2014, 02:21 AM
SamT
It gives me an error.
attached Images
11581


Missing "End If" underneath rows(r).delete

SamT
04-17-2014, 07:04 AM
Option Explicit

Sub Dublikati_SIM_K()
Dim sh As Worksheet, lr As Long, rw As Long
Set sh = Sheets(2) 'Edit Sheet name
Application.ScreenUpdating = False

With sh
lr = .Cells(Rows.Count, 11).End(xlUp).Row

'K, you must sort all three columns (SamT)
'The number column is most unique, sort first.
.UsedRange.Sort Key1:=Range("GG"), Order1:=xlAscending, _
Key2:=Range("KK"), Order2:=xlAscending, _
Key3:=Range("DD"), Order3:=xlAscending, _
Header:=xlYes

For rw = lr To 2 Step -1
If .Cells(rw, 11).Value = .Cells(rw - 1, 11).Value And _
.Cells(rw, 7).Value = .Cells(rw - 1, 7).Value And _
Month(.Cells(rw, 4).Value) = Month(.Cells(rw - 1, 4).Value) Then
.Cells(rw, 1).Resize(1, 24).Delete Shift:=xlUp
End If
Next rw

End With
Application.ScreenUpdating =True
End Sub

k0st4din
04-17-2014, 08:41 AM
11583
hello
or I am very stupid or there is something I do not understand where my mistake comes

SamT
04-17-2014, 09:08 AM
You only sorted the code column("K") (from post number #4)

sh.UsedRange.Sort sh.Range("K2"), xlAscending, Header:=xlYes

You said you want only the month to compare. (Is Column("D") the date column? I do not remember.)
My code:

And _
Month(.Cells(rw, 4).Value) = Month(.Cells(rw - 1, 4).Value) Then

Or I am very stupid and do not understand what you need. :)

Does the code work for you now?

k0st4din
04-17-2014, 10:51 AM
You're not stupid, but maybe I can not explain what I want to happen - therefore I will show (in one file - in this example) what is put on the information and what should remain after macro(right).
This is only an example and should not be moved to the right information (ie what is put and what should be done after macro)
Many thank you for helping me
P.S - And with regard to my previous post - it just showed you that gives me an error - and therefore showed me what "lights up as an error"

SamT
04-17-2014, 04:39 PM
this code is fixed and tested. It is in the same programming style as we have been using. The comments tell you what I fixed and why I did certain things.

Sub Dublikati_SIM_J()
Dim sh As Worksheet, lr As Long, rw As Long
Set sh = Sheets(1) 'Edit Sheet name
Application.ScreenUpdating = False

With sh
lr = .Cells(Rows.Count, "J").End(xlUp).Row


'Changed Sort Order1 to Descending to preserve "no delete" rows
Range("A1").CurrentRegion.Sort Key1:=Range("G:G"), Order1:=xlDescending, _
Key2:=Range("J:J"), Order2:=xlAscending, _
Key3:=Range("D:D"), Order3:=xlAscending, _
Header:=xlYes


For rw = lr To 2 Step -1
'Fixed Cell assignments. Column J is not Columns(11)
If .Cells(rw, "J").Value = .Cells(rw - 1, "J").Value _
And .Cells(rw, "G").Value = .Cells(rw - 1, "G").Value Then
'Next line Raises "Type Mismatch" Error when Anded with above?!?!
If Month(.Cells(rw, "D").Value) = Month(.Cells(rw - 1, "D").Value) Then
'Edit Resize as neededto include correct column
.Cells(rw, 1).Resize(1, 12).Delete Shift:=xlUp
End If
End If
Next rw

End With
Application.ScreenUpdating = True
End Sub

This is the same code. It is in my preferred programming style. It does not look good in the fixed programming style of VBAX. Paste it into the VBA Editor and follow the instructions in the Comment Marks Description section. Use only the programming style you understand the best.

Sub Dublikati_SIM_J()

'Comment marks Description:
'' (2 marks.) Instructions to K0st4din. Delete on satisfaction.
'''' (4 marks.) Section Heading or major code segment.
' (1 mark.) Programmer reason for choosing to code this way.

'' In VBA Editor, move Section Headings to far left, (Delete leading spaces.)


Const DateCol As Long = 4 ''If sheet layout changes, only change these Constants
Const NumCol As Long = 7 ''to maintain code.
Const CodeCol As Long = 10
Const ShtName As String = "Sheet1"


Dim sh As Worksheet
Dim LastRow As Long
Dim rw As Long 'Row Index


Set sh = Sheets(ShtName)
Application.ScreenUpdating = False

''''Sort for Processing
With sh
LastRow = .Cells(Rows.Count, "J").End(xlUp).Row


'Changed Sort Order1 to Descending to preserve "no delete" rows
Range("A1").CurrentRegion.Sort Key1:=Columns(NumCol), Order1:=xlDescending, _
Key2:=Columns(CodeCol), Order2:=xlAscending, _
Key3:=Columns(DateCol), Order3:=xlAscending, _
Header:=xlYes


'''''Processing. Delete Rows per Criteria.
For rw = LastRow To 2 Step -1
'Fixed Cell assignments. Column J is not Columns(11)
If .Cells(rw, CodeCol).Value = .Cells(rw - 1, CodeCol).Value _
And .Cells(rw, NumCol).Value = .Cells(rw - 1, NumCol).Value Then
'Next line Raises "Type Mismatch" Error when Anded with above?!?!
If Month(.Cells(rw, DateCol).Value) = Month(.Cells(rw - 1, DateCol).Value) Then
'Edit Resize as needed
.Cells(rw, 1).Resize(1, CodeCol).Delete Shift:=xlUp
End If
End If
Next rw


''''Restore sort for viewing.
'' Adjust sort as desired
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Columns(DateCol), Order2:=xlAscending, _
Key3:=Columns(NumCol), Order3:=xlAscending, _
Header:=xlYes

End With
Application.ScreenUpdating = True
End Sub

k0st4din
04-19-2014, 06:11 AM
You're an amazing guy, just do not have words to express my gratitude to you.
The second macro is simply amazing. Can I just ask you:
How do I add my deleted two or three columns after the 10(CodeCol) column?


.Cells(rw, 1).Resize(1, '12).Delete Shift:=xlUp '->Here I can tell the macro how many columns to delete (or more precisely how far to delete it) with this number '12

.Cells(rw, 1).Resize(1, CodeCol).Delete Shift:=xlUp ' -> and here to delete 10(CodeCol) column - and I do not know how to add two more columns, but without changing anything else - because the macro works great
If you can not do - Be alive and well and again thank you very much.

SamT
04-19-2014, 07:00 AM
The lazy style is to use
...CodeCol + 2).Delete...

I prefer to add another Constant at the top
Const XXX As Long = 12
Replace XXX with a name constructed with the Column(12) Header, as are the Constant names I used.

Use that new Constant in the line that deletes.
... Resize(1, XXX).Delete ...

I was not thinking of all possibilities when I wrote the macro. In my language, the abbreviation "Num" always means "Number." You may want to change the Constant name "NumCol" to "NumberCol" if that makes more sense where you are. Be sure to change every instance in the macro.

k0st4din
01-20-2015, 01:41 PM
Hello SamT,
nearly a year ago helped me with this macro and to this day I do a great job. Thanks for that.
If you say I will put a brand new topic, but I decided to write this because I need a small change in exactly the same macro created by you. Because the columns are the same (as in the first query) and the macro deletes all reps on 3 criteria but only in the same month.
I need and I do not know how to do it to me shows a (Application.InputBox (Prompt: =) - to me and asked to delete again three criteria, but desirable than a month back months.
Ie if hypothetically assume that I have the 12th (December) month (no day) and Application.InputBox (Prompt: = "How many months back you want to delete the information, excluding the last, ie the 12th?") - And if I write six months back, ie (6) should get the result that I have done in sheet2 (red).
But this red sheet is only to see the result, but actually have to come after the same deletion in Sheet1. Same if I write 7 months back, or 4 months ect....
Upload examples and my macro hoping that might help me.
Also ask you if there is anything you do not understand, I will try to explain.
Thank you in advance.

Sub Dublikati_psihiatri_J()
'Comment marks Description:
'' (2 marks.) Instructions to K0st4din. Delete on satisfaction.
'''' (4 marks.) Section Heading or major code segment.
' (1 mark.) Programmer reason for choosing to code this way.

'' In VBA Editor, move Section Headings to far left, (Delete leading spaces.)


Const DateCol As Long = 4 ''If sheet layout changes, only change these Constants
Const NumCol As Long = 7 ''to maintain code.
Const CodeCol As Long = 10
Const ShtName As String = "my name sheet"


Dim sh As Worksheet
Dim lastrow As Long
Dim rw As Long 'Row Index


Set sh = Sheets(ShtName)
Application.ScreenUpdating = False

''''Sort for Processing
With sh
lastrow = .Cells(Rows.Count, "J").End(xlUp).Row


'Changed Sort Order1 to Descending to preserve "no delete" rows
Range("A1").CurrentRegion.Sort Key1:=Columns(NumCol), Order1:=xlDescending, _
Key2:=Columns(CodeCol), Order2:=xlAscending, _
Key3:=Columns(DateCol), Order3:=xlAscending, _
Header:=xlYes


'''''Processing. Delete Rows per Criteria.
For rw = lastrow To 2 Step -1
'Fixed Cell assignments. Column J is not Columns(11)
If .Cells(rw, CodeCol).Value = .Cells(rw - 1, CodeCol).Value _
And .Cells(rw, NumCol).Value = .Cells(rw - 1, NumCol).Value Then
'Next line Raises "Type Mismatch" Error when Anded with above?!?!
If Month(.Cells(rw, DateCol).Value) = Month(.Cells(rw - 1, DateCol).Value) Then
'Edit Resize as needed
.Cells(rw, 1).Resize(1, CodeCol + 19).Delete Shift:=xlUp
End If
End If
Next rw


''''Restore sort for viewing.
'' Adjust sort as desired
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Columns(DateCol), Order2:=xlAscending, _
Key3:=Columns(NumCol), Order3:=xlAscending, _
Header:=xlYes

End With
Application.ScreenUpdating = True
End Sub

SamT
01-20-2015, 03:01 PM
Keep on top for me bump

k0st4din
01-20-2015, 10:16 PM
Hello SamT,
I apologize, but I do not understand this sentence, what do I need to do. Thank you in advance

k0st4din
01-22-2015, 09:18 AM
SamT?

k0st4din
01-24-2015, 11:20 PM
Bump

k0st4din
01-27-2015, 10:12 PM
Hello everyone,
allowed to make a request and another site (http://www.mrexcel.com/forum/excel-questions/831840-macro-remove-duplicates-three-criteria.html#post4057026) for the reason that I have not received any decision on a slight change of this macro, but still hope for some help from you.
With all my respect to you

k0st4din
02-01-2015, 01:38 AM
Hello everyone,
really ask for some assistance from you, I can not do it alone this macro.
Is it possible to do something about it?

SamT
02-14-2015, 07:00 AM
Just checking in to let everyone know that I'm still alive,

I don't know when I'll be back.

@ K0st4din, Go to http://www.vbaexpress.com and see how much we charge for paid help. I won't be here.

k0st4din
03-16-2015, 01:21 PM
Hello everyone,
I would like to thank each of you who has helped me in times of need and understanding of a problem that I could not do it alone.
My great reverence and gratitude.
I would like to ask you something and I hope to have an administrator who can answer my question that I can not find an answer and it consists in the fact that I ask myself one question: we do not know everything. We can not all, we need your help and support, but also can not afford a number of reasons and points to pay for our helped.
Does this mean that we will be doomed and no one wants to come to the rescue, everything seems to be based only on financial part?
So many years we have received help from you, and now ........
I would be very grateful if someone really respond to my inquiry and I will be very grateful if you believe that you can help us uncomprehending disregarding things called money.
With deep respect and appreciation.

k0st4din
11-01-2015, 11:30 PM
Hello friends,
many asking for some help on this macro.
Everything in it works very, very correctly, but when I rearrange the columns he makes only the specified criteria -> exactly as it should be.
I ask for your help because I do not know how and where to add something that when it starts to perform a specified criteria to move my texts range from A to AC. Ie after 4,7,10 everything works very properly, but I just moved into this range information for each line and then deleting it to AC.
I will repeat the macro is incredible, but do not know how under the same conditions to rearrange information for each line in this range of columns.
Many ask for your assistance.
Thank you in advance.



Sub Dublikati_psihiatri_J()
'Comment marks Description:
'' (2 marks.) Instructions to K0st4din. Delete on satisfaction.
'''' (4 marks.) Section Heading or major code segment.
' (1 mark.) Programmer reason for choosing to code this way.

'' In VBA Editor, move Section Headings to far left, (Delete leading spaces.)


Const DateCol As Long = 4 ''If sheet layout changes, only change these Constants
Const NumCol As Long = 7 ''to maintain code.
Const CodeCol As Long = 10
Const ShtName As String = "my name sheet"


Dim sh As Worksheet
Dim lastrow As Long
Dim rw As Long 'Row Index


Set sh = Sheets(ShtName)
Application.ScreenUpdating = False

''''Sort for Processing
With sh
lastrow = .Cells(Rows.Count, "J").End(xlUp).Row


'Changed Sort Order1 to Descending to preserve "no delete" rows
Range("A1").CurrentRegion.Sort Key1:=Columns(NumCol), Order1:=xlDescending, _
Key2:=Columns(CodeCol), Order2:=xlAscending, _
Key3:=Columns(DateCol), Order3:=xlAscending, _ ' here makes ordering range A through J - exactly as it should be, but how this layout making
Header:=xlYes ' me move information for each row to AC?


'''''Processing. Delete Rows per Criteria.
For rw = lastrow To 2 Step -1
'Fixed Cell assignments. Column J is not Columns(11)
If .Cells(rw, CodeCol).Value = .Cells(rw - 1, CodeCol).Value _
And .Cells(rw, NumCol).Value = .Cells(rw - 1, NumCol).Value Then
'Next line Raises "Type Mismatch" Error when Anded with above?!?!
If Month(.Cells(rw, DateCol).Value) = Month(.Cells(rw - 1, DateCol).Value) Then
'Edit Resize as needed
.Cells(rw, 1).Resize(1, CodeCol + 19).Delete Shift:=xlUp 'here delete to column AC and is correctly
End If
End If
Next rw


''''Restore sort for viewing.
'' Adjust sort as desired
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Columns(DateCol), Order2:=xlAscending, _
Key3:=Columns(NumCol), Order3:=xlAscending, _
Header:=xlYes

End With
Application.ScreenUpdating = True
End Sub

BCHAPPELL
11-11-2015, 04:13 PM
Thank you - this was helpful :)