Excel VBSで選択せずに特定の列の重複値を削除するにはどうすればよいですか？

Question

これはExcelの私のデータであると仮定しますData containing duplicate values in the first three columns。 最初の3つの列の値は、複数の行にわたって繰り返されています。

私は自動的に私のためにこれを行うマクロを使用することを決めたと、私は重複する値を削除し、このVBSコードを発見しただけで、このスクリーンショット duplicate values are removed using a macro

のようなそれらの中に重複する値を削除します。マクロが実際に行うことは、カーソルがある選択された領域の繰り返し値を削除することです。そのため、マクロが実行されるたびに、値を削除したい領域を選択する必要があります。しかし、私が望むのは、列A、B、およびCからそれらが選択されているかどうか、列の数に関係なく重複を削除することです。そして、私はそれが自動的に開いて作業したい。

Selection（）の代わりにRange（）を使用すると考えました。私は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 

それが明示的Range

にWorksheet名前を参照するために、常にはるかに安全だとお考えくださいこれは特にrestoreOriginalValues() subに適用されます。

• AddressRangeオブジェクトのプロパティは、「純粋な」範囲の細胞はそのよう

• 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