Vba excel поиск дубликатов в столбце

файла нет — поэтому ловите VBA (макрос) (для значений <= 255 символов)
xl дома пока отсутствует — тестирование за вами

Sub ПоискПустыхИДублей ()
dim rng as range, cl as range, bad&
set rng=selection

bad=vbred

   for each cl in rng
      if len(cl)=0 or application.worksheetfunction.countif(rng,cl) <>1 then cl.interior.color=bad
   next cl

аргументы функции могут быть другие, я имел ввиду — CountIf ([диапазон], [критерий]) — измените, в случае моей ошибки…
bad — код цвета, меняйте при необходимости, сейчас он «классический» красный и очень неудобный для зрительного восприятия.

Изменено: Jack Famous — 09.10.2018 17:25:58

You can achieve the desired effect by using «Conditional Formatting» feature in Excel Worksheet:

1. Select Column A

2. Click on Conditional Formatting menu button, then select «Highlight Cells Rules» and «Duplicates Values»: specify the color from Drop-Down list.

3. Repeat the same steps for other Columns.

In case you prefer to use your VBA solution which highlights duplicates with different colors, then just apply it to other Columns: see that line

Set rng = Range("A1:A" & Range("A1048576").End(xlUp).Row)

so, instead of Column «A» use Column «B», etc. I would recommend to use iteration through the specified Columns range. With minor changes it can be implemented as shown in the following sample code snippet:

Sub DupEntry()
Dim cel As Variant
Dim rng As Range
Dim clr As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Sample Array of Columns
Dim Col(1 To 3) As String
Col(1) = "A"
Col(2) = "B"
Col(3) = "C"

'Iterate through Columns
For i = 1 To 3
    'Set rng = Range("A1:A" & Range("A1048576").End(xlUp).Row)
    Set rng = Range(Col(i) & "1:" & Col(i) & Range(Col(i) & "1048576").End(xlUp).Row)
    rng.Interior.ColorIndex = xlNone
    clr = 3
    For Each cel In rng
        If Application.WorksheetFunction.CountIf(rng, cel) > 1 Then
            'If Application.WorksheetFunction.CountIf(Range("A1:A" & cel.Row), cel) = 1 Then
            If Application.WorksheetFunction.CountIf(Range(Col(i) & "1:" & Col(i) & cel.Row), cel) = 1 Then
                cel.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cel.Interior.ColorIndex = rng.Cells(WorksheetFunction.Match(cel.Value, rng, False), 1).Interior.ColorIndex
            End If
        End If
    Next
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

(original code lines are commented off). Alternatively, you can use cells R1C1 notation.

Hope this will help. Best regards,

This tutorial will demonstrate how to remove duplicates using the RemoveDuplicates method in VBA.

RemoveDuplicates Method

When data is imported or pasted into an Excel worksheet, it can often contain duplicate values.  You may need to clean the incoming data and remove duplicates.

Fortunately, there is an easy method within the Range object of VBA which allows you to do this.

Range(“A1:C8”).RemoveDuplicates Columns:=1, Header:=xlYes

Syntax is:

RemoveDuplicates([Columns],[Header]

• [Columns] – Specify which columns are checked for duplicate values. All columns much match to be considered a duplicate.
• [Header] – Does data have a header? xlNo (default), xlYes, xlYesNoGuess

Technically, both parameters are optional. However, if you don’t specify the Columns argument, no duplicates will be removed.

The default value for Header is xlNo. Of course it’s better to specify this argument, but if you have a header row, it’s unlikely the header row will match as a duplicate.

RemoveDuplicates Usage Notes

• Before using the RemoveDuplicates method, you must specify a range to be used.
• The RemoveDuplicates method will remove any rows with duplicates found, but will keep the original row with all values.
• The RemoveDuplicates method only works on columns and not on rows, but VBA code can be written to rectify this situation (see later).

Sample Data for VBA Examples

In order to show how the example code works, the following sample data is used:

Remove Duplicate Rows

This code will remove all duplicate rows based only on values in column A:

Sub RemoveDupsEx1()
Range(“A1:C8”).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

Notice that we explicitly defined the Range “A1:C8”. Instead you can used the UsedRange. The UsedRange will determine the last used row and column of your data and apply RemoveDuplicates to that entire range:

Sub RemoveDups_UsedRange()
ActiveSheet.UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

UsedRange is incredibly useful, removing the need for you to explicitly define the range.

After running these code, your worksheet will now look like this:

Notice that because only column A (column 1) was specified, the ‘Apples’ duplicate formerly in row 5 has been removed. However, the Quantity (column 2) is different.

To remove duplicates, comparing multiple columns, we can specify those columns using an Array method.

Remove Duplicates Comparing Multiple Columns

Sub RemoveDups_MultColumns()
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2) , Header:=xlYes
End Sub

The Array tells VBA to compare the data using both columns 1 and 2 (A and B).

The columns in the array do not have to be in consecutive order.

Sub SimpleExample()
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(3, 1) , Header:=xlYes
End Sub

In this example, columns 1 and 3 are used for the duplicate comparison.

This code example uses all three columns to check for duplicates:

Sub SimpleExample()
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3) , Header:=xlYes
End Sub

Removing Duplicate Rows from a Table

The RemoveDuplicates can also be applied to an Excel table in exactly the same way. However, the syntax is slightly different.

Sub SimpleExample()
ActiveSheet.ListObjects("Table1").DataBodyRange.RemoveDuplicates Columns:=Array(1, 3), _
Header:=xlYes
End Sub

This will remove the duplicates in the table based on columns 1 and 3 (A and C).  However, it does not tidy up the color formatting of the table, and you will see colored blank rows left behind at the bottom of the table.

Remove Duplicates From Arrays

If you need to remove duplicate values from an array, of course you can output your array into Excel, use the RemoveDuplicates method, and re-import the array.

However, we also wrote a VBA procedure to remove duplicates from an array.

Removing Duplicates from Rows of Data Using VBA

The RemoveDuplicates method only works on columns of data, but with some ‘out of the box’ thinking, you can create a VBA procedure to deal with rows of data.

Suppose that your data looks like this on your worksheet:

You have the same duplicates as before in columns B and E, but you cannot remove them using the RemoveDuplicates method.

The answer is to use VBA to create an additional worksheet, copy the data into it transposing it into columns, remove the duplicates, and then copy it back transposing it back into rows.

Sub DuplicatesInRows()
    'Turn off screen updating and alerts – we want the code to run smoothly without the user seeing
    ‘what is going on
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    'Add a new worksheet
    Sheets.Add After:=ActiveSheet
    'Call the new worksheet 'CopySheet'
    ActiveSheet.Name = "CopySheet"
    'Copy the data from the original worksheet
    Sheets("DataInRows").UsedRange.Copy
    'Activate the new sheet that has been created
    Sheets("CopySheet").Activate
    'Paste transpose the data so that it is now in columns
    ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
   'Remove the duplicates for columns 1 and 3
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 3), Header _
        :=xlYes
    'Clear the data in the original worksheet
    Sheets("DataInRows").UsedRange.ClearContents
    'Copy the columns of data from the new worksheet created
   Sheets("Copysheet").UsedRange.Copy
   'Activate the original sheet
    Sheets("DataInRows").Activate
    
   'Paste transpose the non-duplicate data
    ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    'Delete the copy sheet - no longer needed
    Sheets("Copysheet").Delete
    'Activate the original sheet
    Sheets("DataInRows").Activate
    'Turn back on screen updating and alerts
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

This code assumes that the original data in rows is held on a worksheet called ‘DataInRows’

After running the code, your worksheet will look like this:

The ‘Apples’ duplicate in column E has now been removed. The user is back in a clean position, with no extraneous worksheets hanging around, and the whole process has been done smoothly with no screen flickering or warning messages.