从excel中找到匹配的工作表中删除行 [英] Delete rows from sheet where match is found in excel

问题描述

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

列A，B， C，D，E，F和G必须是精确匹配。

列H（小时）必须具有与相同值相匹配的负值，而形成一对，那么该对被删除。

所以以下是比赛的一个例子：

  date prod项目标题代码人数小时
 2016 xxx 123测试a12d约翰·史密斯78901 8 
 2016 xxx 123测试a12d约翰·史密斯78901 -8 
 2016 xxx 123测试a12d约翰·史密斯78901 -8 
 2016 xxx 123 test a12d约翰·史密斯78901 -42 
  

导致：

  date prod项目标题代码人数小时
 2016 xxx 123测试a12d约翰·史密斯78901 -8 
 2016 xxx 123测试a12d约翰·史密斯78901 -42 
  

我无法解释，更不用说编写宏！ / p>

  Dim LR As Long 
 Dim i As Long 
 
'删除行
 LR =范围（H& Rows.Count）.End（xlUp）.Row 
对于i = LR到1 Step -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 
结束
 
设置dict = CreateObject（Scripting.Dictionary）
'将其更改为适用的表
 With Sheet1 
 NoCol = .Cells（1，.Columns.Count）.End（xlToLeft）.Column 
'假设工作表的第一行是标题
 headers = .Range（.Cells（。 1），.Cells（1，NoCol））。Value2 
对于每个c In .Range（.Cells（2，1），.Cells（.Cells（.Rows.Count，1）.End（xlUp）喔，1）） 
 ReDim arr（1到NoCol）
 temp = vbNullString 
j = 1 
 Do 
 arr（j）= c.Offset（0，j  -  1）.Value2 
如果j = 8则
 temp = temp& Abs（arr（j））
 Else 
 temp = temp& arr（j）
 End If 
j = j + 1 
循环直到j = NoCol + 1 
 
如果不是dict.exists（temp）而不是temp = vbNullString然后dict.Add key：= temp，Item：= arr 
下一个c 
 .Cells.ClearContents 
 .Range（.Cells（1，1），.Cells（1，NoCol）） .Value2 = headers 
i = 1 
 ReDim结果（1到dict.Count，1到NoCol）
每个键在dict.keys 
对于j = 1到NoCol 
结果（i，j）= dict（key）（j）
下一个j 
i = i + 1 
下一个键
带.Cells（1，1）
 .Range（.Offset（1，0），.Offset（dict.Count，NoCol  -  1））=结果
结束
结束
 
带有应用程序
 .Calculation = calc 
 .ScreenUpdating = True 
 End with 
 End Sub 
  

I have an excel sheet which has just over a thousand lines and I need to be delete all ROWS in it which are as follows:

column A, B,C,D,E,F AND G MUST be an exact match.

Column H (hours) must have a negative value which matches the same value but positive forming a pair, then the pair is deleted.

so the following is an example of a match:

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

resulting in:

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

I'm having trouble explaining it let alone writing a macro!

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

解决方案

One way to do this would be to join all of the columns together using a delimiter and add it to a dictionary as the key. This will only hold unique values. You could then split each one back into columns again and overwrite the whole sheet. There wold be many other ways to achieve this though and this is just an example of one way you could do it. Also, as always if you do try this try it first on a copy of your original data in case of any unexpected behaviour

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

这篇关于从excel中找到匹配的工作表中删除行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！