locked
Remove Duplicates with conditons RRS feed

  • Question

  • Hello All,

    I have the follow macro that removes the duplicates values in a range and insert the result into another range.

    Public Sub Test()

    ActiveSheet.Range("A2:A1000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveSheet.Range("G2"), Unique:=True

    End Sub

    I want that this macro only consider to remove duplicates when two conditions are check:

    - The data that I want to remove duplicates are in the column A;

    - The first condition are in the column B and is when the data in the column B get "MAN";

    - The second condition are in the column C and is when the data in the column C get the number 10.

    Is possible to add this two condition to the macro that I present above?

    Thanks for the time and support

    Monday, May 16, 2016 8:56 PM

All replies

  • Try...

    Option Explicit
    
    Sub ExtractUnique()
    
        Dim rData As Range
        Dim rCriteria As Range
        Dim rCopyTo As Range
        Dim LastRow As Long
        Dim LastCol As Integer
        Dim NextCol As Integer
        
        If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
        
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        If LastRow < 2 Then
            MsgBox "No data found.", vbExclamation
            Exit Sub
        End If
        
        Application.ScreenUpdating = False
        
        LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
        
        Set rData = Range("A1", Cells(LastRow, LastCol))
        
        Cells(1, LastCol + 2).Resize(, 2).Value = Range("B1:C1").Value
        Cells(2, LastCol + 2).Resize(, 2).Value = Array("MAN", 10)
        Set rCriteria = Cells(1, LastCol + 2).Resize(2, 2)
        
        Cells(1, LastCol + 5).Value = Range("A1").Value
        Set rCopyTo = Cells(1, LastCol + 5)
        
        rData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rCriteria, CopyToRange:=rCopyTo, Unique:=True
        
        rCriteria.ClearContents
        
        Application.ScreenUpdating = True
        
    End Sub

    Hope this helps!


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"

    Tuesday, May 17, 2016 11:23 AM
  • Hi Domenic,

    Thanks for the support, i ran the macro and it run :)

    It´s possible to say to the Macro to began to add the output to a defined cell, and then when we refresh the Macro they refresh always in this cell (I will to have to do this to several items and I need to insert them in a determined cells)?


    Thanks again
    Tuesday, May 17, 2016 8:47 PM
  • Sure, just a couple of questions though...

    1) Will your data always contain 3 columns - Column A through Column C ?

    2) Which cell do you want the results to start at?


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"

    Tuesday, May 17, 2016 9:23 PM
  • Assuming that the sheet containing the data is the active sheet, and that Columns A through C contain the data, the following macro will extract the unique values from Column A based on the criteria and place the results in Column G, starting with the header in G1...

    Option Explicit
    
    Sub ExtractUnique()
    
        Dim rData As Range
        Dim rCriteria As Range
        Dim rCopyTo As Range
        Dim LastRow As Long
        Dim LastCol As Integer
        Dim NextCol As Integer
        
        If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
        
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        If LastRow < 2 Then
            MsgBox "No data found.", vbExclamation
            Exit Sub
        End If
        
        Application.ScreenUpdating = False
        
        Range("G1", Cells(1, Columns.Count)).EntireColumn.ClearContents
        
        Set rData = Range("A1:C" & LastRow)
        
        Range("I1:J1").Value = Range("B1:C1").Value
        Range("I2:J2").Value = Array("MAN", 10)
        Set rCriteria = Range("I1:J2")
        
        Range("G1").Value = Range("A1").Value
        Set rCopyTo = Range("G1")
        
        rData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rCriteria, CopyToRange:=rCopyTo, Unique:=True
        
        rCriteria.ClearContents
        
        Application.ScreenUpdating = True
        
    End Sub

    Hope this helps!


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"

    Tuesday, May 17, 2016 11:00 PM
  • Hi again Domenic,


    Sorry to take too much time to came back and reply to it.

    Well this Macro is close to what i want, but there are some points, where it does not work like i want (maybe i think this could be more easy to adapt what I request to what i want effectivelly)

    At this moment I think two points are away of what i want:

    The first - is were the macro get the data and analyse it. So at this moment, the macro take the data in the columns A to C  get the criterias in columns B and C and returns the data of the column A? Right? Can i set the range of this data? for example have the criterias in the columns E and F (take only as an example) and have in the column A the data where I want to make the remove of the duplicates?

    The second - is where the macro copy the results. At this moment the macro clean all the information in the column G and at his right and then copy the data to the cell G1 or below. Its possible to do the macro only clean the cells where it insert new information/data (and why because I want the macro runs several times at the same column but in differents rows, so the macro present the remove duplicates for differents criterias in this differents rows)?

    Once again, thanks for the support and sorry to give the condition almost one by one!!!! To be fare with you i think it will be more easy to manipulate the macro and then adjust like i want :)


    Thanks for the time and support
    Wednesday, May 18, 2016 10:07 PM
  • Sorry, I don't quite understand.  Can you please clarify?

    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"

    Thursday, May 19, 2016 12:24 PM