如何在Excel VBS中删除某些列中的重复值?

Assume that this is my data in Excel Data containing duplicate values in the first three columns. As you can see the values in the first three columns are repeated for a number of rows.

假设这是我在Excel数据中的数据，其中包含前三列中的重复值。正如您所看到的，前三列中的值对于许多行是重复的。

I want to remove the duplicate values in them just like this screenshot duplicate values are removed using a macro

我想删除其中的重复值，就像这个屏幕截图使用宏删除重复值一样

I decided to use a macro that does this for me automatically and I found this VBS code that removes the duplicate values. What the macro actually does is that it removes the repeating values in the selected area where the cursor is in, so each time the macro runs I have to select the area that I would like the values to be removed. But, what I want is to remove the duplicates from the columns A, B, and C whether or not they are selected and no matter how many rows there are. And, I want it to work on open automatically.

我决定使用一个自动为我做这些的宏，我找到了这个VBS代码，它删除了重复的值。宏实际上所做的是删除光标所在的选定区域中的重复值，因此每次运行宏时，我都必须选择要删除的值所在的区域。但是，我想要的是从A、B和C列中删除重复的内容，不管它们是否被选中，也不管有多少行。我想让它自动打开。

I considered using Range() instead of Selection() e.g. I put something like Set r = Columns("A:C").Select but that didn't work. Is there a way to do this in VBS?

我考虑使用Range()而不是Selection()例如，我用Set r = Columns(“A:C”)。选择，但它不起作用。是否有办法在VBS中做到这一点?

Option Explicit

Private originalValues()
Private originalRange As String

Sub removeDupes()
 Dim r As Range 'target range
 Dim arr() 'array to hold values
 Dim i As Long, j As Long, k As Long 'loop control
 Dim upper1D As Long, upper2D As Long, lower2D As Long 'array bounds
 Dim s As String 'temp string to compare values 

  Set r = Selection.Resize(Cells.SpecialCells(xlLastCell).Row)

  If r.Rows.Count = 1 Then Exit Sub 'if the target range is only 1 row then quit
   arr = r.Value 'copy the values in r to the array

 'store the values for an undo
originalValues = r.Value
originalRange = r.Address

upper1D = UBound(arr) 'get the upper bound of the array's 1st dimension
upper2D = UBound(arr, 2) 'get the upper bound of the array's 2nd dimension
lower2D = LBound(arr, 2) 'get the lower bound of the array's 2nd dimension

 'loop through 'rows' in the array
For i = LBound(arr) To upper1D
     'loop through all the 'columns' in the current row
    For j = lower2D To upper2D
        s = arr(i, j) 'record the current array component value in s
         'Check to see if duplicates exists in the target range
        If Application.CountIf(r.Columns(j), s) > 1 _
        And LenB(s) Then
             'Duplicate found: if the end of the array has not ye been reached then
             'loop through the remaining rows for this column, clearing duplicates
            If i < upper1D Then
                For k = i + 1 To upper1D
                    If arr(k, j) = s Then arr(k, j) = ""
                Next k
            End If
        End If
    Next j
Next i
 'copy array back to target range
r.Value = arr
Application.OnUndo "Undo remove duplicates", "restoreOriginalValues"
 End Sub

 Private Sub restoreOriginalValues()
  Range(originalRange).Value = originalValues
 End Sub

Thanks, Laleh

谢谢,问题

1 个解决方案

#1

you have to hardcode the range, like :

你必须硬编码范围，比如:

with Worksheets("MySheet") '<~~ change the worksheet name as per your actual one
    Set r = .Range("A2:C2", .Cells(.Rows.Count, "A").End(xlUp)) '<~~ assuming data are beginning from row 2, otherwise simply change row reference
end with

please consider it's always much safer to explicitly reference the Worksheet name in any Range

请考虑在任何范围内显式引用工作表名称总是安全得多。

this should specially apply to restoreOriginalValues() sub since:

这应该特别适用于restoreOriginalValues() sub，因为:

Address property of Range object would store the "pure" range cells address without any sheet reference

距离对象的地址属性将存储“纯”距离单元格地址，而不需要任何表引用
restoreOriginalValues could be possibly called after some "sheet-jumping"

恢复原值可以在一些“跳页”之后调用

so that you'd better define a module scoped Worksheet variable and then use it

因此，您最好定义一个模块作用域的工作表变量，然后使用它

Private originalValues()
Private originalRange As String
Private mySht As Worksheet '< ~~ set module scoped `Worksheet` variable

Sub removeDupes()

'... code

 originalRange = dataRng.Address '<~~ store the "pure" range cells address without any sheet reference

'... code

End Sub


Private Sub restoreOriginalValues()
    mySht.Range(originalRange).Value = originalValues '< ~~ combine module scoped `Worksheet` and `originalRange` variables 
End Sub

here follows an alternative approach looping through cells instead of using arrays. it's just for reference since arrays are surely faster where lots of data are concerned

这里采用的是另一种方法，即在单元中循环，而不是使用数组。它只是用于引用，因为在涉及大量数据时，数组肯定更快。

Option Explicit

    Private originalValues()
    Private originalRange As String
    Private mySht As Worksheet

    Sub removeDupes()
        Dim cell As Range, compCell As Range
        Dim headerRng As Range, dataRng As Range

        Set mySht = Worksheets("MyData")

        With mySht '<~~ change the worksheet name as per your actual one
            Set headerRng = .Range("A2:C2") '<~~ change the header columns reference as per your needs
            Set dataRng = Range(headerRng.Offset(1), .Cells(.Rows.Count, headerRng.Columns(1).Column).End(xlUp)) '<~~ set data range from row below headers to the row with last non empty cell in first header column

            'store the values for an undo
            originalValues = dataRng.Value
            originalRange = dataRng.Address

            For Each cell In dataRng '<~~ loop through every cell
                Set compCell = IIf(IsEmpty(cell.Offset(-1)), cell.End(xlUp), cell.Offset(-1)) '<~~ set the cell whose value is to compare the current cell value to
                If cell.Value = compCell.Value Then cell.ClearContents '<~~ clear current cell only if its value is the same of its "comparing" cell one
            Next cell

        End With

        restoreOriginalValues

    End Sub


    Private Sub restoreOriginalValues()
        mySht.Range(originalRange).Value = originalValues
    End Sub

#1