Wie Sie doppelte Werte in bestimmten Spalten ohne Auswahl in Excel VBS entfernen?

Question

Angenommen, dies sind meine Daten in Excel Data containing duplicate values in the first three columns. Wie Sie sehen können, werden die Werte in den ersten drei Spalten für eine Anzahl von Zeilen wiederholt.

Ich mag die doppelten Werte in ihnen wie dieser Screenshot einfach entfernen duplicate values are removed using a macro

Ich beschloss, einen Makro zu verwenden, die diese automatisch für mich tut und ich fand diesen VBS-Code, der die doppelten Werte entfernt. Was das Makro tatsächlich tut, ist, dass es die sich wiederholenden Werte in dem ausgewählten Bereich entfernt, in dem sich der Cursor befindet, so dass ich bei jedem Ausführen des Makros den Bereich auswählen muss, in dem die Werte entfernt werden sollen. Aber was ich will, ist, die Duplikate aus den Spalten A, B und C zu entfernen, unabhängig davon, ob sie ausgewählt sind oder nicht, egal wie viele Zeilen es gibt. Und ich möchte, dass es automatisch geöffnet wird.

Ich überlegte, mit Range() anstelle von Auswahl() z. Ich habe etwas wie Set r = Columns("A:C").Select gesetzt, aber das hat nicht funktioniert. Gibt es eine Möglichkeit, dies in VBS zu tun?

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 

Danke, Laleh

Answer 1

Sie haben den Bereich zu codieren, wie:

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 

beachten Sie bitte es ist immer viel sicherer ausdrücklich Worksheet Namen in jeder Range

zu referenzieren dies sollte speziell auf restoreOriginalValues() sub seit:

gelten

• Address Eigenschaft Range Objekt würde speichern die „reinen“ Bereich Zellen ohne Blattbezug Adresse

• restoreOriginalValues möglicherweise nach einiger „Blatt-Springen“ bezeichnet werden könnte

so dass Sie würden besser ein Modul Bereich definieren Worksheet Variable und dann verwenden Sie

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 

Hier folgt ein alternativer Ansatz, der Zellen durchläuft, anstatt Arrays zu verwenden. es ist nur als Referenz, da Arrays schneller sind sicher, wo viele Daten

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