Delete rows from sheet where match is found in excel - excel

Question

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

Answer 1

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

Answer 2

I think (meaning I didn't test :-)) this should do the job.
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
The code prepares two strings consisting of A+B+C+D+E+F (all as strings, not numbers) and compares them. If they are identical, the value in column G is compares with its pendent in the match row * -1. If the two values are identical the row is identified as a match.
The function CompString prepares the comparison strings. The function FindMatch finds the match, and the main routine DeleteMatchingRow does the deleting. I don't have the data to test it on, but in theory it sounds good, doesn't it?
You can use the following function to get a visual of rows which you consider matching but the code doesn't.
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
Paste this code in the same code sheet as the function CompString. Make sure that the sheet from which you want to read a line is active (look at it before switching to the VBE window). Replace the value 3 in the code with the number of the row you wish to read. The compare string will be printed in the VB Editor's Immediate Window (press Ctl+G if you don't see it). Repeat the exercise with the other string. You can then compare them visually and determine why VBA considers them different.