Question

假设这是我在Excel Data containing duplicate values in the first three columns中的数据。正如您所看到的，前三列中的值会重复多行。

我想删除它们中的重复值，就像这个截图一样 duplicate values are removed using a macro

我决定使用一个自动执行此操作的宏，我发现这个VBS代码可以删除重复的值。宏实际上做的是它删除光标所在区域中的重复值，因此每次运行宏时我必须选择我想要删除值的区域。但是，我想要的是从列A，B和C中删除重复项，无论它们是否被选中，无论有多少行。并且，我希望它能够自动打开。

我考虑使用Range（）而不是Selection（），例如我把Set r = Columns("A:C").Select之类的东西放了，但那不起作用。有没有办法在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

谢谢，拉尔赫

Answer 1

你必须对范围进行硬编码，例如：

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

请注意在任何Worksheet

中明确引用Range名称总是更安全

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

Address Range对象的属性将存储“纯”范围单元格地址，而不包含任何工作表参考
restoreOriginalValues

这样您最好定义一个模块作用域Worksheet变量，然后使用它

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

下面是循环遍历单元而不是使用数组的替代方法。它仅供参考，因为在涉及大量数据的情况下，数组肯定更快

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

如何在Excel VBS中未经选择的情况下删除某些列中的重复值？

1 个答案: