Question

我有一张超过一千行的excel表，我需要删除其中的所有ROWS，如下所示：

A，B，C，D，E，F和G列必须完全匹配。

H列（小时）必须具有匹配相同值的负值，但是形成一对的正值，则该对将被删除。

所以以下是匹配的示例：

date    prod    Item    Title   Code    person      number  hours
2016    xxx     123     test    a12d    John Smith  78901   8
2016    xxx     123     test    a12d    John Smith  78901   -8
2016    xxx     123     test    a12d    John Smith  78901   -8
2016    xxx     123     test    a12d    John Smith  78901   -42

导致：

date    prod    Item    Title   Code    person      number  hours
2016    xxx     123     test    a12d    John Smith  78901   -8
2016    xxx     123     test    a12d    John Smith  78901   -42

我无法解释它，更不用说写一个宏了！

Dim LR As Long
Dim i As Long

'Remove rows 
LR = Range("H" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
    'How do i compare it against other rows?
Next i

Answer 1

执行此操作的一种方法是使用分隔符将所有列连接在一起，并将其作为键添加到字典中。这只会保留唯一值。然后，您可以再将每个分成多个列并覆盖整个工作表。虽然有许多其他方法可以实现这一目标，但这只是你可以做到的一种方式的一个例子。此外，一如既往，如果您尝试此操作，请先在原始数据的副本上尝试，以防出现任何意外行为

Option Explicit
Public Sub ExampleRemoveDuplicates()
    Dim dict As Object
    Dim temp As String
    Dim calc As String
    Dim headers As Variant
    Dim NoCol As Long, i As Long, j As Long
    Dim c, key

    With Application
        .ScreenUpdating = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With

    Set dict = CreateObject("Scripting.Dictionary")
    ' Change this to the sheet that is applicable
    With Sheet1
        NoCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ' Assumes first row of sheet is headers
        headers = .Range(.Cells(1, 1), .Cells(1, NoCol)).Value2
        For Each c In .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
            ReDim arr(1 To NoCol)
            temp = vbNullString
            j = 1
            Do
                arr(j) = c.Offset(0, j - 1).Value2
                If j = 8 Then
                    temp = temp & Abs(arr(j))
                Else
                    temp = temp & arr(j)
                End If
                j = j + 1
            Loop Until j = NoCol + 1

            If Not dict.exists(temp) And Not temp = vbNullString Then dict.Add key:=temp, Item:=arr
        Next c
        .Cells.ClearContents
        .Range(.Cells(1, 1), .Cells(1, NoCol)).Value2 = headers
        i = 1
        ReDim Results(1 To dict.Count, 1 To NoCol)
        For Each key In dict.keys
            For j = 1 To NoCol
                Results(i, j) = dict(key)(j)
            Next j
            i = i + 1
        Next key
        With .Cells(1, 1)
            .Range(.Offset(1, 0), .Offset(dict.Count, NoCol - 1)) = Results
        End With
    End With

    With Application
        .Calculation = calc
        .ScreenUpdating = True
    End With
End Sub

Answer 2

我认为（意思是我没有测试:-)）这应该可以胜任。

Option Explicit

Sub DeleteMatchingRow()
    ' 30 Mar 2017

    Dim Rl As Long
    Dim R As Long

    Application.ScreenUpdating = False
    With ActiveSheet
        Rl = .Range("H" & .Rows.Count).End(xlUp).Row
        For R = Rl To 2 Step -1
            If FindMatch(CompString(.Rows(R)), Val(.Cells(R, 8).Value), R) Then
                .Rows(R).EntireRow.Delete
            End If
        Next R
    End With
    Application.ScreenUpdating = Treu
End Sub

Private Function FindMatch(ByVal Comp1 As String, _
                           ByVal Gval As Integer, _
                           ByVal LR As Long) As Long
    ' 30 Mar 2017
    ' return the row number where a match was found
    ' or return 0, if no match was found

    Dim R As Long
    Dim Comp2 As String

    With ActiveSheet
        For R = LR To 1 Step -1
            Comp2 = CompString(.Rows(R))
            If StrComp(Comp1, Comp2, vbBinaryCompare) = 0 Then
                If .Cells(R, 8).Value = (Gval * -1) Then
                    FindMatch = R
                    Exit Function
                End If
            End If
        Next R
    End With
End Function

Private Function CompString(Row As Range) As String
    ' 30 Mar 2017

    Dim Fun As String
    Dim C As Long

    With Row
        For C = 1 To 7
            Fun = Fun & CStr(.Cells(C).Value)
        Next C
    End With
    CompString = Fun
End Function

代码准备两个字符串，包括A + B + C + D + E + F（全部为字符串，而不是数字）并进行比较。如果它们相同，则将G列中的值与其在匹配行* -1中的下垂进行比较。如果两个值相同，则将该行标识为匹配。

CompString函数准备比较字符串。 FindMatch函数找到匹配项，主例程DeleteMatchingRow执行删除操作。我没有测试它的数据，但理论上听起来不错，不是吗？

您可以使用以下函数来获取您认为匹配的行的视觉效果，但代码却没有。

Private Sub TestMatch()
    ' 31 Mar 2017

    Dim R As Long

    R = 3
    With ActiveSheet
        Debug.Print CompString(.Rows(R)), "Column G has "; .Cells(R, 8).Value
    End With
End Sub

将此代码粘贴到与CompString函数相同的代码表中。确保要读取行的工作表处于活动状态（在切换到VBE窗口之前查看它）。将代码中的值3替换为您要读取的行的编号。比较字符串将打印在VB编辑器的立即窗口中（如果没有看到，则按Ctl + G）。用另一个字符串重复练习。然后，您可以直观地比较它们，并确定VBA认为它们不同的原因。

从工作表中删除在excel中找到匹配项的行

2 个答案: