Delete all rows including cells in column "A" that are identical to the values in cells "D1", "E1","F1" and "A6".

[harzer]

Hello everyone,
My VBA skills do not allow me to solve my problem, hence my request to the experts among you.
The headers of my table are as indicated in the first line (see image). All the cells in this first line keep the same values except cell "E1" which changes according to the user's needs, this cell always contains a number which varies from 1 to 20 maximum.
To solve my problem, we will work mainly on column "A", let me explain.
The second cell (non-empty) of column "A" is cell "A10", for information, the line number of this 2nd cell is variable, hence the need to determine the line number and the value from its cell each time Macro is launched to place them in variables that we will use in the macro.
Next, we will determine the row of the 3rd (non-empty) cell of column "A", (in our case, it is row 24), the row number of this 3rd non-empty cell is variable, d 'where the need to determine its number each time the Macro is launched.
Next, we will determine the last cell of column "A", the number of the last line is variable, hence the need to determine the number of the last line each time the Macro is launched.
The goal of the code is to delete all lines (entire) that start at the line of the 3rd non-empty cell (In our case here, it is from line 24), and that end at the last line of the column "A", (in our present case, it is line no. 45), when the cells of column "A" are identical to the cells found in cells "D1", "E1","F1 " and "A6"
As my data is important and in order to allow the macro to be very fast, I would like to ask you to use tables with: For i = LBound(DelValues) To UBound(DelValues).
In summary, the cells to allow the tests to be carried out are colored yellow, the lines which must be deleted are colored green.
I remain at your disposal for further information.
Thank you for your contributions.

Classeur1.xlsx
	A	B	C	D	E	F
1	Consanguinité			Nbre de générations	20	Max 20 Générations
2
3				976-054/2017 M
4			392-019/2018 M
5				392-043/2017 F
6		3024-066/2020 M
7				2203-008/2015 M
8			2207-067/2017 F
9				2207-029-2014 F
10	3024-060/2023 M
11				2207-079/2015 M
12			2207-089/2018 M
13				2207-021/2017 F
14		2207-032/2020 F
15				2207-058/2017 M
16			2207-006/2019 F
17				2207-029/2014 F
18
19
20
21
22
23
24	Max 20 Générations	3
25	3024-060/2023 M	2
26	Max 20 Générations	2
27	3024-060/2023 M	1
28	392-019/2018 M	1
29	392-043/2017 F	1
30	Nbre de générations	1
31	2203-008/2015 M	1
32	2207-067/2017 F	1
33	3024-060/2023 M	1
34	Nbre de générations	1
35	2207-089/2018 M	1
36	3024-060/2023 M	1
37	Nbre de générations	1
38	2207-058/2017 M	1
39	20	1
40	Nbre de générations	1
41	20	1
42	Max 20 Générations	1
43	20	1
44	Nbre de générations	1
45	Max 20 Générations	1
Pedigree

 

[DanteAmor]

when the cells of column "A" are identical to the cells found in cells "D1", "E1","F1 " and "A6"

Continuing with your example, the second non-empty cell should be A10.

As my data is important and in order to allow the macro to be very fast...

Consider that deleting rows is always a slow process, it depends on several factors, the number of rows, formulas, conditional formats, etc.
I prepared 3 options for you, try to see which one is faster for you.

Option 1

Sub DeleteRows_1()
  Dim sh As Worksheet
  Dim sr As Long, tr As Long, lr As Long
  Dim ar As Range
 
  Application.ScreenUpdating = False
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
 
  lr = sh.Range("A" & Rows.Count).End(3).Row
 
  Set ar = sh.Range("A1:A" & lr).SpecialCells(xlCellTypeConstants)
  sr = ar.Areas.Item(2).Row
  tr = ar.Areas.Item(3).Row
 
  sh.Range("A" & tr - 1 & ":A" & lr).AutoFilter 1, _
    Array(sh.Range("A" & sr).Text, sh.Range("D1").Text, sh.Range("E1").Text, sh.Range("F1").Text), xlFilterValues
 
  sh.AutoFilter.Range.Offset(1).EntireRow.Delete
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  Application.ScreenUpdating = True
End Sub

Option 2

Sub DeleteRows_2()
  Dim sh As Worksheet
  Dim sr As Long, tr As Long, lr As Long, i As Long
  Dim ar As Range, rng As Range
  Dim a As Variant
 
  Application.ScreenUpdating = False
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
 
  lr = sh.Range("A" & Rows.Count).End(3).Row
  a = sh.Range("A1:A" & lr).Value
  Set rng = sh.Range("A" & lr + 1)

  Set ar = sh.Range("A1:A" & lr).SpecialCells(xlCellTypeConstants)
  sr = ar.Areas.Item(2).Row
  tr = ar.Areas.Item(3).Row
 
  For i = tr To lr
    Select Case a(i, 1)
      Case sh.Range("A" & sr).Value, sh.Range("D1").Value, sh.Range("E1").Value, sh.Range("F1").Value
        Set rng = Union(rng, sh.Range("A" & i))
    End Select
  Next
 
  If Not rng Is Nothing Then rng.EntireRow.Delete
  Application.ScreenUpdating = True
End Sub

Option 3
The following option works if from the third not empty cell downwards: you do not have formulas in columns A and B and if you only have data in columns A and B. Since in this case it does not "delete" the row, it replaces the values.

Sub DeleteRows_3()
  Dim sh As Worksheet
  Dim sr As Long, tr As Long, lr As Long, i As Long, j As Long
  Dim ar As Range, rng As Range
  Dim a As Variant, b As Variant
  Dim d1, d2, d3, d4
 
  Application.ScreenUpdating = False
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
 
  lr = sh.Range("A" & Rows.Count).End(3).Row
  a = sh.Range("A1:B" & lr).Value
 
  Set ar = sh.Range("A1:A" & lr).SpecialCells(xlCellTypeConstants)
  sr = ar.Areas.Item(2).Row
  tr = ar.Areas.Item(3).Row
  d1 = sh.Range("A" & sr).Value
  d2 = sh.Range("D1").Value
  d3 = sh.Range("E1").Value
  d4 = sh.Range("F1").Value
  ReDim b(1 To UBound(a, 1) - tr + 1, 1 To 2)
 
  For i = tr To UBound(a, 1)
    Select Case a(i, 1)
      Case d1, d2, d3, d4
      Case Else
        j = j + 1
        b(j, 1) = a(i, 1)
        b(j, 2) = a(i, 2)
    End Select
  Next
 
  sh.Range("A" & tr).Resize(UBound(b, 1), UBound(b, 2)).Value = b
  Application.ScreenUpdating = True
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[Peter_SSs]

.. allow the macro to be very fast ..

Especially if that third section in column A is very large and there are lots of disjoint rows to be deleted, you should find this very fast.
We don't know that much about what your data could actually be like but this code will also
- retain any specific formatting that is applied to the remaining data & remove the unwanted rows, including any formatting
- still work if that second cell with data in column A happens to be in cell A2 or in the cell immediately above the third non-blank cell (A23 in your sample)

Sub harzer()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim c2 As Range, c3 As Range
  Dim nc As Long, i As Long, k As Long
  
  Set c2 = Columns("A").Find(What:="*")
  Set d = CreateObject("Scripting.Dictionary")
  d(Range("D1").Value) = 1
  d(Range("E1").Value) = 1
  d(Range("F1").Value) = 1
  d(c2.Value) = 1
  Set c3 = Columns("A").Find(What:="*", After:=c2)
  a = Range(c3, Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If d(a(i, 1)) = 1 Then
      k = k + 1
      b(i, 1) = 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    With c3.Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[harzer]

Hello DanteAmor & Peter_SSs.
Thank you for your answers.
Here is my report:
1. First important point, the 4 codes give me the desired result, Bravo to both.
2. With my data, ± 32000 lines, the two fastest codes are:
The 3rd code of DanteAmor "DeleteRows_3" and the code of Peter_SSs. They run so quickly that to see how much time has passed, I set a timer. To tell the truth, I don't have any preferences, I keep the 2 codes.
I just have one small additional request of both, namely, how to display a Msgbox which tells me that we have deleted "X" Lines out of a total of "Y" Lines.
Thanks again for sharing your knowledge.
Greetings.

 

[DanteAmor]

I just have one small additional request of both, namely, how to display a Msgbox which tells me that we have deleted "X" Lines out of a total of "Y" Lines.

Try this:

Sub DeleteRows_3()
  Dim sh As Worksheet
  Dim sr As Long, tr As Long, lr As Long, i As Long, j As Long
  Dim ar As Range, rng As Range
  Dim a As Variant, b As Variant
  Dim d1, d2, d3, d4
  
  Application.ScreenUpdating = False
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  
  lr = sh.Range("A" & Rows.Count).End(3).Row
  a = sh.Range("A1:B" & lr).Value
  
  Set ar = sh.Range("A1:A" & lr).SpecialCells(xlCellTypeConstants)
  sr = ar.Areas.Item(2).Row
  tr = ar.Areas.Item(3).Row
  d1 = sh.Range("A" & sr).Value
  d2 = sh.Range("D1").Value
  d3 = sh.Range("E1").Value
  d4 = sh.Range("F1").Value
  ReDim b(1 To UBound(a, 1) - tr + 1, 1 To 2)
  
  For i = tr To UBound(a, 1)
    Select Case a(i, 1)
      Case d1, d2, d3, d4
      Case Else
        j = j + 1
        b(j, 1) = a(i, 1)
        b(j, 2) = a(i, 2)
    End Select
  Next
  
  sh.Range("A" & tr).Resize(UBound(b, 1), UBound(b, 2)).Value = b
  Application.ScreenUpdating = True
  
  MsgBox "We have deleted: " & UBound(b) - j & " Lines out of a total of: " & UBound(b) & " Lines"
End Sub

Happy to help you, have a nice day!

 

[harzer]

Hello DanteAmor,
Thanks for updating the code (Display of the number of lines deleted compared to the total number of lines)
Looking forward to reading from you on another occasion.
Greetings.

 

[Peter_SSs]

Am I correct then in thinking that the second value in column A (A10) in the example can never be in A2 or A23 (if the 3rd non-zero value is in A24)?

Also, can you confirm that none of the cells in the bottom section (in any column) have different formatting to other cells in the column?

To get the message box with my code requires the addition of the highlighted line below.

Sub harzer()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim c2 As Range, c3 As Range
  Dim nc As Long, i As Long, k As Long
  
  Set c2 = Columns("A").Find(What:="*")
  Set d = CreateObject("Scripting.Dictionary")
  d(Range("D1").Value) = 1
  d(Range("E1").Value) = 1
  d(Range("F1").Value) = 1
  d(c2.Value) = 1
  Set c3 = Columns("A").Find(What:="*", After:=c2)
  a = Range(c3, Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If d(a(i, 1)) = 1 Then
      k = k + 1
      b(i, 1) = 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    With c3.Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
  MsgBox "We have deleted " & k & " Lines out of a total of " & UBound(b) & " Lines"
End Sub

 

[harzer]

Thank you Peter_SSs for your code update.
That's wonderful.
Thank you and we look forward to hearing from you in other circumstances.
Friendships.

 

[Peter_SSs]

You're welcome.

(But do you have answers to my two questions? )

 

[harzer]

Am I correct then in thinking that the second value in column A (A10) in the example can never be in A2 or A23 (if the 3rd non-zero value is in A24)?

yes, I agree with you.

Also, can you confirm that none of the cells in the bottom section (in any column) have different formatting to other cells in the column?

No, there is no different formatting.