Удаление повторяющихся строк в excel vba

In this Article

  • RemoveDuplicates Method
  • RemoveDuplicates Usage Notes
    • Sample Data for VBA Examples
    • Remove Duplicate Rows
    • Remove Duplicates Comparing Multiple Columns
    • Removing Duplicate Rows from a Table
    • Remove Duplicates From Arrays
    • Removing Duplicates from Rows of Data Using VBA

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:

VBA 16 PIC 01

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:

VBA 16 PIC 02

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.

VBA Coding Made Easy

Stop searching for VBA code online. Learn more about AutoMacro — A VBA Code Builder that allows beginners to code procedures from scratch with minimal coding knowledge and with many time-saving features for all users!

automacro

Learn More

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:

VBA 16 PIC 03

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:

VBA 16 PIC 04

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.

Источник

Удаление повторяющихся значений (дубликатов) в диапазоне ячеек с помощью кода VBA Excel. Метод Range.RemoveDuplicates — синтаксис, параметры, примеры.

Метод Range.RemoveDuplicates

Метод Range.RemoveDuplicates предназначен в VBA Excel для удаления повторяющихся значений по столбцам в заданном диапазоне ячеек рабочего листа. Строки с обнаруженными дубликатами удаляются целиком.

Синтаксис метода Range.RemoveDuplicates

expression. RemoveDuplicates (Columns , Header),

где expression — переменная или выражение, возвращающее объект Range.

Параметры метода Range.RemoveDuplicates

Наименование Описание
Columns Массив индексов столбцов, содержащих ячейки с повторяющимися значениями. Обязательный параметр. Тип данных – Variant.
Header Указывает, содержит ли первая строка диапазона заголовок, который не участвует в поиске дубликатов:

  • xlNo — первая строка списка не содержит заголовок (значение по умолчанию);
  • xlYes — первая строка диапазона содержит заголовок;
  • xlGuess — VBA Excel решает сам, есть ли у списка заголовок.

Необязательный параметр. Тип данных – XlYesNoGuess.

Метод работает как с круглыми скобками, в которые заключены параметры, так и без них. Если требуется указать несколько столбцов в параметре Columns, следует использовать функцию Array, например, Array(2, 3).

Примеры удаления дубликатов

Исходная таблица для всех примеров

Исходная таблица для удаления дубликатов

По третьей колонке легко определить, какие строки были удалены.

Пример 1
Удаление повторяющихся значений по первому столбцу:

Range("A1:C10").RemoveDuplicates 1

или

Range(Cells(1, 1), Cells(10, 3)).RemoveDuplicates (1)

Второй вариант позволяет использовать вместо индексов строк и столбцов переменные. Наличие или отсутствие скобок, в которые заключен параметр Columns, на работу метода не влияет.

Результат:

Пример 2
Удаление дубликатов по первому столбцу с указанием, что первая строка содержит заголовок:

Range("A1:C10").RemoveDuplicates 1, xlYes

Результат:

Здесь мы видим, что первая строка не учитывалась при поиске повторяющихся значений.

Пример 3
Удаление дубликатов по первому и второму столбцам:

Range("A1:C10").RemoveDuplicates Array(1, 2)

Результат:

Обратите внимание, что при удалении повторяющихся значений по нескольким столбцам, будут удалены дубли только тех строк, в которых во всех указанных столбцах содержатся одинаковые значения. В третьем примере удалены «лишние» строки с дублями значений по двум первым столбцам: Корова+Лягушка, Свинья+Бурундук и Овца+Собака.

Смотрите, как отобрать уникальные значения из списка в VBA Excel с помощью объекта Collection и объекта Dictionary.

Источник

I have a worksheet with two columns: Date and Name. I want to delete all rows that are exact duplicates, leaving only unique values.

Here is my code (which doesn’t work):

Sub DeleteRows()

Dim rng As Range
Dim counter As Long, numRows As Long

With ActiveSheet
    Set rng = ActiveSheet.Range("A1:B" & LastRowB)
End With
numRows = rng.Rows.Count

For counter = numRows To 1 Step -1
    If rng.Cells(counter) Like rng.Cells(counter) - 1 Then
        rng.Cells(counter).EntireRow.Delete
    End If
Next

End Sub

It’s «Like rng.Cells(counter)-1» that seems to be the cause- I get «Type Mismatch».

Community's user avatar

asked Jun 7, 2013 at 16:25

4

There’s a RemoveDuplicates method that you could use:

Sub DeleteRows()

    With ActiveSheet
        Set Rng = Range("A1", Range("B1").End(xlDown))
        Rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    End With

End Sub

answered Jun 7, 2013 at 16:40

fbonetti's user avatar

fbonettifbonetti

6,5823 gold badges33 silver badges32 bronze badges

5

The duplicate values in any column can be deleted with a simple for loop.

Sub remove()
Dim a As Long
For a = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & a), Cells(a, 1)) > 1 Then Rows(a).Delete
Next
End Sub

Martijn Pieters's user avatar

answered Nov 23, 2016 at 17:04

kadrleyn's user avatar

kadrleynkadrleyn

3341 silver badge5 bronze badges

Источник

Assume I have a block of data in Excel 2010, 100 rows by 3 columns.

Column C contains some duplicates, say it starts off as

1, 1, 1, 2, 3, 4, 5, ….. , 97, 98

Using VBA, I would like to remove the duplicate rows so I am left with 98 rows and 3 columns.

1, 2, 3, ….. , 97, 98

I know there is a button in Excel 2010 to do that but it inteferes with the rest of my code subsequently and gives incorrect results.

Furthermore, I would like to do it in arrays, then paste the results on the worksheet, rather than methods such as Application.Worksheetfunction.countif(.....

So something like:

Dim myarray() as Variant
myarray=cells(1,1).Currentregion.value

Dim a as Long

For a=1 to Ubound(myarray,1)

    'something here to 

Next a

Community's user avatar

asked Aug 8, 2012 at 17:39

Yht H's user avatar

1

I answered a similar question. Here is the code I used:

Dim dict As Object
Dim rowCount As Long
Dim strVal As String

Set dict = CreateObject("Scripting.Dictionary")

rowCount = Sheet1.Range("A1").CurrentRegion.Rows.Count

'you can change the loop condition to iterate through the array rows instead
Do While rowCount > 1
  strVal = Sheet1.Cells(rowCount, 1).Value2

  If dict.exists(strVal) Then
    Sheet1.Rows(rowCount).EntireRow.Delete
  Else
    'if doing this with an array, then add code in the Else block
    ' to assign values from this row to the array of unique values
    dict.Add strVal, 0
  End If

  rowCount = rowCount - 1
Loop

Set dict = Nothing

If you want to use an array, then loop through the elements with the same conditional (if/else) statements. If the item doesn’t exist in the dictionary, then you can add it to the dictionary and add the row values to another array.

Honestly, I think the most efficient way is to adapt code you’d get from the macro recorder. You can perform the above function in one line:

    Sheet1.UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes

Community's user avatar

answered Aug 8, 2012 at 17:56

Zairja's user avatar

ZairjaZairja

1,43112 silver badges31 bronze badges

5

Function eliminateDuplicate(poArr As Variant) As Variant
    Dim poArrNoDup()

    dupArrIndex = -1
    For i = LBound(poArr) To UBound(poArr)
        dupBool = False

        For j = LBound(poArr) To i
            If poArr(i) = poArr(j) And Not i = j Then
                dupBool = True
            End If
        Next j

        If dupBool = False Then
            dupArrIndex = dupArrIndex + 1
            ReDim Preserve poArrNoDup(dupArrIndex)
            poArrNoDup(dupArrIndex) = poArr(i)
        End If
    Next i

    eliminateDuplicate = poArrNoDup
End Function

Andriy Makukha's user avatar

answered Oct 30, 2013 at 21:12

RBILLC's user avatar

RBILLCRBILLC

1702 silver badges6 bronze badges

2

Simple function to remove duplicates from a 1D array

Private Function DeDupeArray(vArray As Variant) As Variant
  Dim oDict As Object, i As Long
  Set oDict = CreateObject("Scripting.Dictionary")
  For i = LBound(vArray) To UBound(vArray)
    oDict(vArray(i)) = True
  Next
  DeDupeArray = oDict.keys()
End Function

Edit:

With stdVBA (a library largely maintained by myself) you can use:

uniqueValues = stdEnumerator.CreateFromArray(myArray).Unique().AsArray()

answered Jun 14, 2019 at 8:51

Sancarn's user avatar

SancarnSancarn

2,54318 silver badges43 bronze badges

3

An improvement on @RBILLC and @radoslav006 answers, this version searches the array with the duplicates removed for existing values so it searchs less values to find a duplicate.

Public Function RemoveDuplicatesFromArray(sourceArray As Variant)
    Dim duplicateFound As Boolean
    Dim arrayIndex As Integer, i As Integer, j As Integer
    Dim deduplicatedArray() As Variant
    
    arrayIndex = -1
    deduplicatedArray = Array(1)

    For i = LBound(sourceArray) To UBound(sourceArray)
        duplicateFound = False

        For j = LBound(deduplicatedArray) To UBound(deduplicatedArray)
            If sourceArray(i) = deduplicatedArray(j) Then
                duplicateFound = True
                Exit For
            End If
        Next j

        If duplicateFound = False Then
            arrayIndex = arrayIndex + 1
            ReDim Preserve deduplicatedArray(arrayIndex)
            deduplicatedArray(arrayIndex) = sourceArray(i)
        End If
    Next i

    RemoveDuplicatesFromArray = deduplicatedArray
End Function

answered Oct 25, 2020 at 5:34

Darryls99's user avatar

Darryls99Darryls99

9116 silver badges10 bronze badges

Here’s another approach for working with an array:

Sub tester()

    Dim arr, arrout
    
    arr = Range("A1").CurrentRegion.Value   'collect the input array
     
    arrout = UniqueRows(arr)                'get only unique rows
    
    Range("H1").Resize(UBound(arrout, 1), UBound(arrout, 2)).Value = arrout
    
End Sub




Function UniqueRows(arrIn As Variant) As Variant
    Dim keys, rw As Long, col As Long, k, sep, arrout
    Dim dict As Object, lbr As Long, lbc As Long, ubr As Long, ubc As Long, rwOut As Long
    Set dict = CreateObject("scripting.dictionary")
    'input array bounds
    lbr = LBound(arrIn, 1)
    ubr = UBound(arrIn, 1)
    lbc = LBound(arrIn, 2)
    ubc = UBound(arrIn, 2)
    ReDim keys(lbr To ubr)
    'First pass:collect all the row "keys" in an array 
    '    and unique keys in a dictionary
    For rw = lbr To ubr
        k = "": sep = ""
        For col = lbc To ubc
            k = k & sep & arrIn(rw, col)
            sep = Chr(0)
        Next col
        keys(rw) = k     'collect key for this row
        dict(k) = True   'just collecting unique keys
    Next rw

    'Resize output array to # of unique rows
    ReDim arrout(lbr To dict.Count + (lbr - 1), lbc To ubc)
    rwOut = lbr
    'Second pass: copy each unique row to the output array
    For rw = lbr To ubr
        If dict(keys(rw)) Then      'not yet output?
            For col = lbc To ubc    'copying this row over to output...
                arrout(rwOut, col) = arrIn(rw, col)
            Next col
            rwOut = rwOut + 1      'increment output "row"
            dict(keys(rw)) = False 'flag this key as copied
        End If
    Next rw
    UniqueRows = arrout
End Function

answered Jan 6, 2022 at 23:21

Tim Williams's user avatar

Tim WilliamsTim Williams

150k8 gold badges96 silver badges124 bronze badges

Answer from @RBILLC could be easily improved by adding an Exit For inside internal loop:

Function eliminateDuplicate(poArr As Variant) As Variant
    Dim poArrNoDup()

    dupArrIndex = -1
    For i = LBound(poArr) To UBound(poArr)
        dupBool = False

        For j = LBound(poArr) To i
            If poArr(i) = poArr(j) And Not i = j Then
                dupBool = True
                Exit For
            End If
        Next j

        If dupBool = False Then
            dupArrIndex = dupArrIndex + 1
            ReDim Preserve poArrNoDup(dupArrIndex)
            poArrNoDup(dupArrIndex) = poArr(i)
        End If
    Next i

    eliminateDuplicate = poArrNoDup
End Function

answered Feb 21, 2020 at 13:48

radoslav006's user avatar

I think this is really a case for using excel’s native functions, at least for the initial array acquisition, and I don’t think there’s any simpler way to do it. This sub will output the unique values starting in column 5. I assumed that the target range was empty, so if it’s not, change r and c.

Sub testUniques()
    
    Dim arr, r As Long, c As Long, h As Long, w As Long
    Dim this As Worksheet: Set this = ActiveSheet
    arr = Application.Unique(this.Cells(1, 1).CurrentRegion)
    
    r = 1
    c = 5
    h = UBound(arr, 1) - 1
    w = UBound(arr, 2) - 1
    
    this.Range(this.Cells(r, c), this.Cells(r + h, c + w)) = arr
    
End Sub

answered Aug 18, 2021 at 22:03

Chris Strickland's user avatar

Chris StricklandChris Strickland

3,3281 gold badge15 silver badges18 bronze badges

0

I know this is old, but here’s something I used to copy duplicate values to another range so that I could see them quickly to establish data integrity for a database I was standing up from various spreadsheets. To make the procedure delete the duplicates it would be as simple as replacing the dupRng lines with Cell.Delete Shift:=xlToLeft or something to that effect.

I haven’t tested that personally, but it should work.

Sub PartCompare()
    Dim partRng As Range, partArr() As Variant, i As Integer
    Dim Cell As Range, lrow As Integer

    lrow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    i = 0

    Set partRng = ThisWorkbook.Worksheets("Sheet1").Range(Cells(1, 1), Cells(lrow, 1))

    For Each Cell In partRng.Cells
        ReDim Preserve partArr(i)
        partArr(i) = Cell.Value
        i = i + 1
    Next

    Dim dupRng As Range, j As Integer, x As Integer, c As Integer

    Set dupRng = ThisWorkbook.Worksheets("Sheet1").Range("D1")

    x = 0
    c = 1
    For Each Cell In partRng.Cells
        For j = c To UBound(partArr)
            If partArr(j) = Cell.Value Then
                dupRng.Offset(x, 0).Value = Cell.Value
                dupRng.Offset(x, 1).Value = Cell.Address()
                x = x + 1
                Exit For
            End If
        Next j
        c = c + 1
    Next Cell
End Sub

answered May 16, 2019 at 13:35

TOTM's user avatar

TOTMTOTM

1077 bronze badges

Remove duplicates (plus related row items) from array

As OP wanted a VBA solution close to RemoveDuplicates, I demonstrate an array approach using a ►dictionary to get not the unique items per se (dict.keys), but the related row indices of first occurrencies (dict.items).

These are used to retain the whole row data via procedure LeaveUniques profiting from the advanced possibilities of the ►Application.Index() function — c.f. Some peculiarities of the the Application.Index function

Example Call

Sub ExampleCall()
'[0]define range and assign data to 1-based 2-dim datafield
    With Sheet1                   ' << reference to your project's sheet Code(Name)
        Dim lastRow: lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        Dim rng:  Set rng = .Range("C2:E" & lastRow)
    End With
    Dim data: data = rng        ' assign data to 2-dim datafield
'[1]get uniques (column 1) and remove duplicate rows
    LeaveUniques data           ' << call procedure LeaveUniques (c.f. RemoveDuplicates)
'[2]overwrite original range
    rng.Clear
    rng.Resize(UBound(data), UBound(data, 2)) = data
End Sub

Procedure LeaveUniques

Sub LeaveUniques(ByRef data As Variant, Optional ByVal colNum As Long = 1)
'Purpose: procedure removes duplicates of given column number in entire array
    data = Application.Index(data, uniqueRowIndices(data, colNum), nColIndices(UBound(data, 2)))
End Sub

Help functions to LeaveUniques

Function uniqueRowIndices(data, Optional ByVal colNum As Long = 1)
'Purpose: return data index numbers referring to uniques
'a) set late bound dictionary to memory
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
'b) slice e.g. first data column (colNum = 1)
    Dim colData
    colData = Application.Index(data, 0, colNum)
'c) fill dictionary with uniques referring to first occurencies
    Dim i As Long
    For i = 1 To UBound(colData)
        If Not dict.exists(dict(colData(i, 1))) Then dict(colData(i, 1)) = i
    Next
'd) return 2-dim array of valid unique 1-based index numbers
    uniqueRowIndices = Application.Transpose(dict.items)
End Function

Function nColIndices(ByVal n As Long)
'Purpose: return "flat" array of n column indices, e.g. for n = 3 ~> Array(1, 2, 3)
    nColIndices = Application.Transpose(Evaluate("row(1:" & n & ")"))
End Function

answered Oct 25, 2020 at 19:52

T.M.'s user avatar

T.M.T.M.

9,2393 gold badges32 silver badges57 bronze badges

Источник
 

rango13

Пользователь

Сообщений: 11
Регистрация: 16.07.2015

#1

16.07.2015 07:40:26

Всем привет!

Нужно удалить все повторяющиеся(и пустые) строки(без дубликатов) на основании первого столбца. Удаленные строки остаются пустыми.
ДО:

Скрытый текст

ПОСЛЕ:

Скрытый текст

Сначала использовал встроенную функцию поиска одинаковых значений в выделенном тексте, немного доработал, но результата всё равно нет.

Код 
Sub Макрос1()
'
' Макрос1 Макрос
' Сначала макрос ищет одинаковые строки в первом столбце и когда находит - помечает их цветом(как и значения внутри ячейки).
' Затем макрос проходит от последней ячейки снизу до самой первой в поисках ячеек в первом столбце, которые закрашены определенным цветом. 
' Их-то он и должен удалять. Но не удаляет.

    Columns("A:A").Select
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    
    For i = (ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count) To 1 Step -1
        If    (Selection.Cells(i, 1).Interior.Color = 13551615) Then
              Selection.Rows(i).Delete Shift:=xlUp
        End If
    Next i
    Selection.FormatConditions(1).StopIfTrue = False
End Sub
 

SAS888

Пользователь

Сообщений: 757
Регистрация: 01.01.1970

#2

16.07.2015 07:51:29

Можно так:

Код 
Sub qq()
    Dim x As Range, i As Long
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If Application.CountIf([A:A], Cells(i, 1)) > 1 Or Cells(i, 1) = "" Then _
        If x Is Nothing Then Set x = Rows(i) Else Set x = Union(x, Rows(i))
    Next
    If Not x Is Nothing Then x.Delete
End Sub

Изменено: SAS888 — 16.07.2015 07:55:10

Чем шире угол зрения, тем он тупее.

 

rango13

Пользователь

Сообщений: 11
Регистрация: 16.07.2015

#3

16.07.2015 08:11:02

Код 
Sub qq()
' Задаём переменную
    Dim x As Range, i As Long


' Запускаем цикл, который идёт с первой строки по последнюю
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
'  Здесь только понял, что если просматриваемые строки в первом столбце >1(это как?) или пусты, тогда _(что это значит?)
        If Application.CountIf([A:A], Cells(i, 1)) > 1 Or Cells(i, 1) = "" Then _
' Второй цикл выполняется, если условие предыдущего верно. Если значение переменной "x" пусто, значит присваиваем ей номер строки, иначе что?
        If x Is Nothing Then Set x = Rows(i) Else Set x = Union(x, Rows(i))
    Next
' Если значение переменной "x" не пусто, тогда значение "x" удаляется.
    If Not x Is Nothing Then x.Delete
End Sub

Если Вас не затруднит, можете описать? Пытаюсь сам разобраться, но пока плохо получается.
 

SAS888

Пользователь

Сообщений: 757
Регистрация: 01.01.1970

#4

16.07.2015 08:22:25

Цикл здесь один. Проходим по всем ячейкам столбца «A», проверяем требуемые условия, формируем диапазон строк для последующего удаления.
И если этот диапазон есть, то удаляем.
Тот же код с комментариями:

Код 
Sub qq()
'Определяем иеременные
    Dim x As Range, i As Long
'Организуем цикл от 1-ой до последней заполненной строки в 1-ом столбце
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
'Если количество ячеек в столбце "A", содержащих текущее значение, больше 1, либо ячейка пуста, то...
        If Application.CountIf([A:A], Cells(i, 1)) > 1 Or Cells(i, 1) = "" Then _
'Если в "x" пусто, то присваиваем "x" текущую строку. Иначе - добавляем ее к существующему "x"
        If x Is Nothing Then Set x = Rows(i) Else Set x = Union(x, Rows(i))
    Next
'Если в "x" не пусто, то удаляем диапазон "x"
    If Not x Is Nothing Then x.Delete
End Sub

Изменено: SAS888 — 16.07.2015 08:24:47

Чем шире угол зрения, тем он тупее.

 

Слэн

Пользователь

Сообщений: 5192
Регистрация: 16.01.2013

я бы заметил , что countif — это тоже цикл, с перебором всех заполненных ячеек между прочим, на каждом шаге цикла, правда с этим трудно бороться.. словари побыстрее проверку осуществляют — их можно задействовать
и проверка на каждом шаге if not is nothing тоже не слишком экономно — проверять можно до первого присваивания, а затем уже не имеет смысла. Да в коде будет два цикла, но последовательных, а не вложенных, и с тем же суммарным количеством шагов..

Изменено: Слэн — 16.07.2015 11:15:14
 

Слэн

Пользователь

Сообщений: 5192
Регистрация: 16.01.2013

#6

16.07.2015 11:22:49

да, и оператор or в if then заставляет делать обязательно две проверки, тогда как исполнитья может только одно из условий — эффективнее делать:

Код 
if Cells(i, 1) <> "" Then
   if Application.CountIf([A:A], Cells(i, 1)) > 1 then
      ...
   endif
endif

Живи и дай жить..

 

TheBestOfTheBest

Пользователь

Сообщений: 2366
Регистрация: 03.04.2015

Excel 2010 +PLEX +SaveToDB +PowerQuery

В #1 а почему удалены все строки со значением 1? разве не должно остаться хотя бы одной?

Неизлечимых болезней нет, есть неизлечимые люди.

 

Юрий М

Модератор

Сообщений: 60588
Регистрация: 14.09.2012

Контакты см. в профиле

#8

16.07.2015 12:01:29

Нет:

Цитата
rango13 написал:
Нужно удалить все повторяющиеся(и пустые) строки(без дубликатов)
 

Спасибо знатокам за данный код. А возможно ли в данном случае сделать так, чтобы оставалась хотя бы одна строка из найденных дубликатов?

P.S. макрорекодер в данном случае не помогает, т.к. стандартная remove duplicates сдвигает ячейки вверх, заполняя пустые, и ячейки в строке теряют взаимосвязанность по данным. А настройки «оставить ячейки найденных дубликатов пустыми» не наблюдается=.

Изменено: Кирилл Блинов — 31.08.2020 20:35:02
(дополнение)
 

vikttur

Пользователь

Сообщений: 47199
Регистрация: 15.09.2012

#10

31.08.2020 23:40:17

Создайте отдельную тему
Источник

В этом руководстве будет показано, как удалить дубликаты с помощью метода RemoveDuplicates в VBA.

Метод RemoveDuplicates

Когда данные импортируются или вставляются на лист Excel, они часто могут содержать повторяющиеся значения. Возможно, вам потребуется очистить входящие данные и удалить дубликаты.

К счастью, в объекте Range в VBA есть простой метод, который позволяет это сделать.

1 Диапазон («A1: C8»). Столбцы RemoveDuplicates: = 1, Header: = xlYes

Синтаксис:

RemoveDuplicates ([Столбцы], [Заголовок]

  • [Столбцы] — Укажите, в каких столбцах проверяются повторяющиеся значения. Все столбцы совпадают, чтобы считаться дубликатами.
  • [Заголовок] — Есть ли у данных заголовок? xlNo (по умолчанию), xlYes, xlYesNoGuess

Технически оба параметра необязательны. Однако, если вы не укажете аргумент Columns, никакие дубликаты не будут удалены.

Значение по умолчанию для заголовка — xlNo. Конечно, лучше указать этот аргумент, но если у вас есть строка заголовка, маловероятно, что строка заголовка будет соответствовать как дубликат.

Замечания по использованию RemoveDuplicates

  • Перед использованием метода RemoveDuplicates необходимо указать используемый диапазон.
  • Метод RemoveDuplicates удалит все строки с найденными дубликатами, но сохранит исходную строку со всеми значениями.
  • Метод RemoveDuplicates работает только со столбцами, а не со строками, но для исправления этой ситуации можно написать код VBA (см. Ниже).

Образцы данных для примеров VBA

Чтобы показать, как работает пример кода, используются следующие образцы данных:

Удалить повторяющиеся строки

Этот код удалит все повторяющиеся строки только на основе значений в столбце A:

123 Sub RemoveDupsEx1 ()Диапазон («A1: C8»). Удалить дубликаты столбцов: = 1, заголовок: = xl ДаКонец подписки

Обратите внимание, что мы явно определили диапазон «A1: C8». Вместо этого вы можете использовать UsedRange. UsedRange определит последнюю использованную строку и столбец ваших данных и применит RemoveDuplicates ко всему этому диапазону:

123 Sub RemoveDups_UsedRange ()Столбцы ActiveSheet.UsedRange.RemoveDuplicates: = 1, заголовок: = xlYesКонец подписки

UsedRange невероятно полезен, избавляя вас от необходимости явно определять диапазон.

После запуска этого кода ваш рабочий лист теперь будет выглядеть так:

Обратите внимание, что, поскольку был указан только столбец A (столбец 1), дубликат «Яблоки», ранее находившийся в строке 5, был удален. Однако количество (столбец 2) отличается.

Чтобы удалить дубликаты, сравнивая несколько столбцов, мы можем указать эти столбцы с помощью метода Array.

Удалить дубликаты, сравнивая несколько столбцов

123 Sub RemoveDups_MultColumns ()Столбцы ActiveSheet.UsedRange.RemoveDuplicates: = Массив (1, 2), Заголовок: = xl ДаКонец подписки

Массив сообщает VBA о необходимости сравнения данных с использованием столбцов 1 и 2 (A и B).

Столбцы в массиве не обязательно должны располагаться в последовательном порядке.

123 Sub SimpleExample ()Столбцы ActiveSheet.UsedRange.RemoveDuplicates: = Массив (3, 1), Заголовок: = xl ДаКонец подписки

В этом примере столбцы 1 и 3 используются для повторяющегося сравнения.

В этом примере кода для проверки дубликатов используются все три столбца:

123 Sub SimpleExample ()Столбцы ActiveSheet.UsedRange.RemoveDuplicates: = Массив (1, 2, 3), Заголовок: = xl ДаКонец подписки

Удаление повторяющихся строк из таблицы

Удалить дубликаты можно точно так же применить к таблице Excel. Однако синтаксис немного отличается.

1234 Sub SimpleExample ()Столбцы ActiveSheet.ListObjects («Table1»). DataBodyRange.RemoveDuplicates: = Array (1, 3), _Заголовок: = xlYesКонец подписки

Это приведет к удалению дубликатов в таблице на основе столбцов 1 и 3 (A и C). Однако он не приводит в порядок цветовое форматирование таблицы, и вы увидите цветные пустые строки, оставленные в нижней части таблицы.

Удаление дубликатов из массивов

Если вам нужно удалить повторяющиеся значения из массива, конечно, вы можете вывести свой массив в Excel, использовать метод RemoveDuplicates и повторно импортировать массив.

Однако мы также написали процедуру VBA для удаления дубликатов из массива.

Удаление дубликатов из строк данных с помощью VBA

Метод RemoveDuplicates работает только со столбцами данных, но, если подумать «нестандартно», вы можете создать процедуру VBA для работы со строками данных.

Предположим, что ваши данные на листе выглядят так:

У вас есть те же дубликаты, что и раньше, в столбцах B и E, но вы не можете удалить их с помощью метода RemoveDuplicates.

Ответ состоит в том, чтобы использовать VBA для создания дополнительного рабочего листа, копирования данных в него, транспонируя их в столбцы, удаляя дубликаты, а затем копируя их обратно, перемещая обратно в строки.

12345678910111213141516171819202122232425262728293031323334353637 Sub DuplicatesInRows ()’Отключите обновление экрана и предупреждения — мы хотим, чтобы код работал плавно, и пользователь не видел’что здесь происходитApplication.ScreenUpdating = FalseApplication.DisplayAlerts = False’Добавить новый рабочий листТаблицы.Добавить после: = ActiveSheet’Назовите новый рабочий лист’ CopySheet ‘ActiveSheet.Name = «CopySheet»‘Скопируйте данные из исходного листаТаблицы («DataInRows»). UsedRange.Copy’Активируйте новый созданный листТаблицы («Копия»). Активировать’Вставить, транспонировать данные так, чтобы они теперь располагались в столбцахActiveSheet.Range («A1»). PasteSpecial Paste: = xlPasteAll, Operation: = xlNone, SkipBlanks: = _Ложь, Транспонировать: = Истина’Удалите дубликаты столбцов 1 и 3Столбцы ActiveSheet.UsedRange.RemoveDuplicates: = Массив (1, 3), Заголовок _: = xlДа’Очистить данные на исходном листеТаблицы («DataInRows»). UsedRange.ClearContents’Скопируйте столбцы данных из нового созданного листаТаблицы («Copysheet»). UsedRange.Copy’Активировать исходный листТаблицы («DataInRows»). Активировать’Вставить транспонировать недублирующиеся данныеActiveSheet.Range («A1»). PasteSpecial Paste: = xlPasteAll, Operation: = xlNone, SkipBlanks: = _Ложь, Транспонировать: = Истина’Удалить копию листа — больше не требуетсяТаблицы («Копия»). Удалить’Активировать исходный листТаблицы («DataInRows»). Активировать’Включите обновление экрана и предупрежденияApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueКонец подписки

В этом коде предполагается, что исходные данные в строках хранятся на листе под названием «DataInRows».

После запуска кода ваш рабочий лист будет выглядеть так:

Дубликат «Яблоки» в столбце E был удален. Пользователь вернулся в чистое положение, без каких-либо посторонних рабочих листов, и весь процесс прошел гладко, без мерцания экрана или предупреждающих сообщений.

Источник

Excel VBA code to remove duplicates from a given range of cells. In the below data set we have given a list of 15 numbers in “Column A” range A1:A15.  Need to remove duplicates and place unique numbers in column B.

Sample Data: Cells A1:A15

Sample Data

Final Output:

VBA Code to remove duplicates and place into next column (B)

Declare Variables:

Variables Data Type Comments
nonDuplicate Boolean It is a Boolean value (True/False).
uNo Integer Count no of Unique items in column B
colA Integer Iteration column A cells
colB Integer Iteration column B cells 
'Variable Declarations
Dim nonDuplicate As Boolean, uNo As Integer, colA As Integer, colB As Integer

Always first value will be unique, So A1 place to cell B1

'Place first value to B1
Cells(1, 2).Value = Cells(1, 1).Value

Initialize variables:

'Initialize uNo = 1 since first number is already placed in column B; Assign True to the variable nonDuplicate

uNo = 1

nonDuplicate= True

Since the first number is already placed in cell B1, Loop starts from A2 to A15.  Take each number from Column A and check with Column B (unique range)

'Use for loop to check each number from A2 to A15 
For colA = 2 To 15
    For colB = 1 To uNo

if the number is already placed in column B.  Assign False to the “nonDuplicate” variable.

        If Cells(colA, 1).Value = Cells(colB, 2).Value Then
            nonDuplicate= False
        End If

“nonDuplicate” is True then place to column B and increase uNo by 1

    'if nonDuplicate is true, place cell value in column B and increase uNo = uNo + 1
    If nonDuplicate = True Then
        Cells(uNo + 1, 2).Value = Cells(colA, 1).Value
        uNo = uNo + 1
    End If

Reset “nonDuplicate” variable 

'reset nonDuplicate to True
nonDuplicate = True

Close for loop

Next colA

Implementation:

Follow the below steps to remove duplicates using Excel VBA:

Step 1: Add a shape (VBA Remove Duplicates) to your worksheet  

Step 2: Right-click on “VBA Remove Duplicates” and “Assign Macro..”

Step 3: Select “removeDuplicates”, you can see a list of macros available in your workbook

Step 4: Save your excel file as “Excel Macro-Enabled Workbook” *.xlsm

Step 5: Click “VBA Remove Duplicates” to execute VBA code and see the output

Источник

Понравилась статья? Поделить с друзьями:
  • Удаление повторяющихся значений в excel в одном столбце
  • Удаление повторов в ячейке excel
  • Удаление переносов строк в word
  • Удаление переноса строки excel
  • Удаление перевода строки в excel