Loop through the range and then sheets and delete rows based on cell value

Question

I'm working on a loop that will feed of a cell in sheet "Results" and go through number of worksheets (at the moment set to 1-3) and delete the row where it finds the value from sheet "Results". At the moment it fails, can you please advise?

Sub Del_Rows()

Dim rng As Range, cell As Range, del As Range
Dim sht As Worksheet

For x = 1 To 3
    Set sht = Sheets(x)
    Set del = Sheets("Results").Range("A13")

    Set rng = Intersect(sht.Range("A1:A2000"), sht.UsedRange)
    For Each cell In rng.Cells
    If (cell.Value) = Sheets("Results").Range("A13") Then 
        If del Is Nothing Then
            Set del = cell
        Else
            Set del = Union(del, cell)
        End If
    End If
    Next cell

    If del Is del Then del.EntireRow.Delete

Next x

End Sub

Also, I understand it might be a lot trickier to do but is it possible for the code to have a look at the dynamic range in sheet("Results") one by one?

What I mean is e.g. the code takes the value of Sheets("Results").Range("A13") and does the search for the value across the sheets 1-3 deleting rows when it finds it, and then it moves to Sheets("Results").Range("A14") and does the same thing.

Since the data in [Sheets("Results").Range("A13") + last row] is dynamic it simply does the same thing until it reaches the end (e.g. Sheets("Results").Range("A20").

Thanks a lot

Answer 1

I didn't test the code, so maybe there's some syntax error or typo.

Dim wb as workbook
Set wb = ActiveWorkbook
set rsws = wb.worksheets("Results")
dim lastResult as Long
lastResult = rsws.Usedrange.SpecialCells(xlCelltypeLastcell).Row 'count the last row of ResultSheet.
dim lastrowCheck as Long

for each ws in wb.worksheets 'loop through each worksheet
  lastrowCheck = ws.Usedrange.SpecialCells(xlCelltypeLastcell).Row
  if ws.name <> "Results" then
     for i = 1 to lastResult 'loop through each Result range cell
        for j = 1 to lastrowCheck  'loop throught and check value
           if rsws.cells(i,13) <> vbNullString then
                if rsws.cells(i,13) = ws.cells(j,1) then 'I suppose that it's in the first column.
            'your deleting code here
                end if
            end if
         next j
     next i
  end if
next ws

Below is the actual code in my excel which includes some debug print.

Sub testtesttest()
Dim wb As Workbook
Set wb = ActiveWorkbook
Set rsws = wb.Worksheets("Results")
Dim lastResult As Long
lastResult = rsws.UsedRange.SpecialCells(xlCellTypeLastCell).Row 'count the last row of ResultSheet.
Dim lastrowCheck As Long

For Each ws In wb.Worksheets 'loop through each worksheet
  lastrowCheck = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
  Debug.Print "lastrowCheck "; lastrowCheck
  Debug.Print ws.name
  If ws.name <> "Results" Then
     For i = 1 To lastResult 'loop through each Result range cell
        For j = 1 To lastrowCheck  'loop throught and check value
           If rsws.Cells(i, 13) = ws.Cells(j, 1) Then 'I suppose that it's in the first column.
            'your deleting code here
             Debug.Print "good good good"
            End If
         Next j
     Next i
  End If
Next ws

End Sub

Answer 2

I have managed to work on my initial code and came up with the following solution, which works for me.

Public Sub Loop_DEL()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'----------------------------------------------------------------------
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'----------------------------------------------------------------------
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, rng6 As Range, rng7 As Range, rng8 As Range, c As Range
Dim rngToDel2 As Range, rngToDel3 As Range, rngToDel4 As Range, rngToDel5 As Range, rngToDel6 As Range, rngToDel7 As Range, rngToDel8 As Range
Dim lastRow As Long

With Worksheets("Results")
   lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   Set rng1 = .Range("A3:A" & lastRow)
End With

Set rng2 = Worksheets("ANY SCORE").Range("A:A")
Set rng3 = Worksheets("Page1").Range("A:A")
Set rng4 = Worksheets("Page2").Range("A:A")
Set rng5 = Worksheets("Page3").Range("A:A")
Set rng6 = Worksheets("Page4").Range("A:A")
Set rng7 = Worksheets("Page5").Range("A:A")
Set rng8 = Worksheets("Page6").Range("A:A")

For Each c In rng2
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel2 Is Nothing Then
   Set rngToDel2 = c
   Else
   Set rngToDel2 = Union(rngToDel2, c)
End If
End If
   Next c
   If Not rngToDel2 Is Nothing Then rngToDel2.EntireRow.Delete

For Each c In rng3
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel3 Is Nothing Then
   Set rngToDel3 = c
   Else
   Set rngToDel3 = Union(rngToDel3, c)
End If
End If
   Next c
   If Not rngToDel3 Is Nothing Then rngToDel3.EntireRow.Delete

For Each c In rng4
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel4 Is Nothing Then
   Set rngToDel4 = c
   Else
   Set rngToDel4 = Union(rngToDel4, c)
End If
End If
   Next c
   If Not rngToDel4 Is Nothing Then rngToDel4.EntireRow.Delete

For Each c In rng5
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel5 Is Nothing Then
   Set rngToDel5 = c
   Else
   Set rngToDel5 = Union(rngToDel5, c)
End If
End If
   Next c
   If Not rngToDel5 Is Nothing Then rngToDel5.EntireRow.Delete

For Each c In rng6
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel6 Is Nothing Then
   Set rngToDel6 = c
   Else
   Set rngToDel6 = Union(rngToDel6, c)
End If
End If
   Next c
   If Not rngToDel6 Is Nothing Then rngToDel6.EntireRow.Delete

For Each c In rng7
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel7 Is Nothing Then
   Set rngToDel7 = c
   Else
   Set rngToDel7 = Union(rngToDel7, c)
End If
End If
   Next c
   If Not rngToDel7 Is Nothing Then rngToDel7.EntireRow.Delete

For Each c In rng8
   If Not IsError(Application.Match(c.Value, rng1, 0)) Then
   If rngToDel8 Is Nothing Then
   Set rngToDel8 = c
   Else
   Set rngToDel8 = Union(rngToDel8, c)
End If
End If
   Next c
   If Not rngToDel8 Is Nothing Then rngToDel8.EntireRow.Delete

SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub