从Excel中find匹配的表格中删除行
我有一个超过一千行的Excel表，我需要删除它的所有行，如下所示：
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
我无法解释它，更不用说编写一个macros！
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
一种方法是使用分隔符将所有列连接在一起，并将其作为键添加到字典中。 这只会保持独特的价值。 然后，您可以将每一个分割回列，并覆盖整个工作表。 除此之外还有很多其他的方法可以做到这一点，这只是你能做到的一个例子。 此外， 如果您确实尝试过这种方法，则可以先尝试使用原始数据的副本，以防意外行为发生
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
我想（这意味着我没有testing:-)）这应该做的工作。
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组成的string（都是string，不是数字），并将它们进行比较。 如果它们相同，则列G中的值与其匹配行* 1中的下标相比较。 如果两个值相同，则该行被识别为匹配。
函数CompString准备比较string。 函数FindMatchfind匹配项，主程序DeleteMatchingRow进行删除。 我没有数据来testing它，但理论上听起来不错，不是吗？
您可以使用以下函数来获取您认为匹配的行的可视化，但代码不可以。
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窗口之前查看它）。 将代码中的值3replace为您想要读取的行的编号。 比较string将打印在VB编辑器的即时窗口中（如果没有看到，请按Ctl + G）。 用另一个string重复练习。 然后，您可以直观地比较它们并确定VBA为何认为它们不同。