如何删除Excel VBS中没有select的某些列中的重复值？
假设这是我在Excel 数据中的数据，其中包含前三列中的重复值 。 正如你所看到的，前三列的值是对许多行重复的。
我想删除它们中的重复值，就像这个截图一样， 使用macros删除重复的值
我决定使用一个macros为我自动做这个，我发现这个VBS代码，删除重复的值。 macros实际上做的是删除光标所在区域中的重复值，所以每次macros运行时，我必须select要删除值的区域。 但是，我想要的是从列A，B和C删除重复项，无论它们是否被选中，无论有多less行。 而且，我希望它自动打开。
我考虑使用范围（）而不是select（）例如我把类似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
谢谢，Laleh
你必须硬编码的范围，如：
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
请考虑在任何Range明确引用Worksheet名称总是更为安全
这应该特别适用于restoreOriginalValues()子，因为：
-
Range对象的Address属性将存储没有任何工作表引用的“纯”范围单元格地址 -
restoreOriginalValues可能会被称为一些“跳页”
所以你最好定义一个模块范围的Worksheetvariables，然后使用它
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