Delete section of data based on one entry in section meeting certain criteria using excel vba - excel

Question

I have one excel sheet (lets say sheet A) that has data in it, organized into groupings separated by an empty row and grouped by a common entry in column N. Within each grouping, I need to check another excel sheet (lets say sheet B) in a different workbook to see if any of the entries in column A of sheet A matches any entries in sheet B's column C. If any of the column C entries match those of the column A entries in a single grouping of the first sheet, I do not do anything to that grouping. If there are no matches, I need to delete the whole grouping. Below is my attempt, but I am mostly getting confused with 1. how to delete just a grouping and 2. how to call to each sheet/column correctly.
Sub DeleteAdjacent()
Dim wb1 As Workbook, Dim wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
Dim lastrow1 As Long, Dim lastrow2 As Long, Dim i As Long, Dim j As Long
Set wb1 = Workbooks("Workbook1.xlsx")
Set wb2 = Workbooks("Workbook2.xlsx")
Set sh2 = wb2.Sheets(“Sheet B”)
Set sh1 = wb1.Sheets("Sheet A")
lastrow1 = sh1.Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
For j = lastrow1 To 1 Step -1
cell = "N" & j
cell1 = "N" & (j - 1)
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
For i = lastrow2 To 1 Step -1
cell2 = "C" & i
cell3 = "A" & j
If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range(j, cell).EntireRow.Delete
Loop
End If
Next i
Loop
Next j
End Sub
Edit: Looking at my attempt more closely, it would actually do the opposite of what I'd want to do. I attempted to delete the entire grouping when there was a match, when I actually want the exact opposite. I think then the part below should be changed.
If sh1.Cells(j, cell3).Value = sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range.Cells(j, cell).EntireRow.Delete
Loop
End If
My attempt at correcting this is maybe too simple?
If sh1.Cells(j, cell3).Value <> sh2.Cells(i, cell2).Value Then
Do While sh1.Cells(j, cell).Value = sh1.Cells(j, cell1).Value
sh1.Range.Cells(j, cell).EntireRow.Delete
Loop
End If

Answer 1

I think if I were attacking this problem I wouldn't compare A with C and do the group looping check in the same process. It might be easier to get your head around the issue if you create a map of values to groups first. Say a value of 10 exists in groups 1,3 and 5, then you could just check for a 10 and immediately eliminate 3 groups from your future checks. A Collection of Collections would serve you well for this as the look up by key is very fast and you don't have to worry about the number of items it stores.
If you also had a collection of Ranges for each group then it would be a simple process of eliminating matching groups and then, in one hit, delete all the remaining Ranges.
The code below should do that for you (but as with any row delete code, I'd suggest you back up your raw data first!):
Public Sub DeleteAdjacent()
Dim ws As Worksheet
Dim valueGroupMap As Collection
Dim groupRanges As Collection
Dim values As Collection
Dim lastRow As Long
Dim groupRng As Range
Dim valueCell As Range
Dim groupCell As Range
Dim rng As Range
Dim v As Variant
Dim r As Long
'Read the Column A worksheet
Set ws = Workbooks("Workbook1.xlsx").Worksheets("Sheet A")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1 '+1 to get a blank row at end
'Define the value map group ranges
Set valueGroupMap = New Collection
Set groupRanges = New Collection
Set groupRng = ws.Cells(1, "N")
For r = 1 To lastRow
Set valueCell = ws.Cells(r, "A")
Set groupCell = ws.Cells(r, "N")
If Len(CStr(groupCell.Value2)) = 0 Then
'We've reached the end of a group
Set rng = ws.Range(groupRng, groupCell.Offset(-1))
groupRanges.Add rng, CStr(groupRng.Value2)
Set groupRng = Nothing
Else
'We're working within a group
If groupRng Is Nothing Then
Set groupRng = groupCell
End If
'Create the value to group map
Set values = Nothing
On Error Resume Next
Set values = valueGroupMap(CStr(valueCell.Value2))
On Error GoTo 0
If values Is Nothing Then
Set values = New Collection
valueGroupMap.Add values, CStr(valueCell.Value2)
End If
values.Add CStr(groupRng.Value2)
End If
Next
'Read the Column C worksheet
Set ws = Workbooks("Workbook2.xlsx").Worksheets("Sheet B")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For r = 1 To lastRow
'Check if we have the value
Set values = Nothing
Set values = valueGroupMap(CStr(ws.Cells(r, "C").Value2))
If Not values Is Nothing Then
'We do, so remove the group ranges from our list
For Each v In values
groupRanges.Remove CStr(v)
Next
End If
Next
On Error GoTo 0
'Create a range of the groups still remaining in the list
Set rng = Nothing
For Each groupRng In groupRanges
If rng Is Nothing Then
Set rng = groupRng
Else
Set rng = Union(rng, groupRng)
End If
Next
'Delete that range
rng.EntireRow.Delete
End Sub