Delete 100000 rows based on matching the value for first row with last row

[Maklil]

Hello
I have multiple ranges in Details sheet if the second row (under header for each range contains value is the same value where is in lastrow(TOTAL) in column E or the lastrow(TOTAL) contains zero in column E then should delete the ranges , otherwise should keep the rest
I have about 100000 rows and increasable .

Merging ranges_3.xlsb
	A	B	C	D	E
1	DATE	CUSTOMER	INV NO	ITEM	QTY
2	11/11/2000	CSS-100	INV-A123	ITTT-100/AS-1	200
3	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	100
4	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	40
5	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	50
6	TOTAL				190
7
8
9	DATE	CUSTOMER	INV NO	ITEM	QTY
10	11/12/2000	CSS-100	INV-A123	ITTT-100/AS-2	300
11	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-2	400
12	TOTAL				400
13
14
15	DATE	CUSTOMER	INV NO	ITEM	QTY
16	11/15/2000	CSS-100	INV-A124	ITTT-100/AS-2	600
17	1/7/2023	CSS-100	INV-A124	ITTT-100/AS-2	300
18	1/7/2023	CSS-100	INV-A124	ITTT-100/AS-2	100
19	1/7/2023	CSS-100	INV-A124	ITTT-100/AS-2	200
20	TOTAL				600
21
22
23	DATE	CUSTOMER	INV NO	ITEM	QTY
24	11/17/2000	CSS-100	INV-A129	ITTT-100/AS-7	800
25	1/7/2023	CSS-100	INV-A129	ITTT-100/AS-7	500
26	1/7/2023	CSS-100	INV-A129	ITTT-100/AS-7	200
27	1/7/2023	CSS-100	INV-A129	ITTT-100/AS-7	100
28	TOTAL				0
DETAILS

should be

Merging ranges_3.xlsb
	A	B	C	D	E
1	DATE	CUSTOMER	INV NO	ITEM	QTY
2	11/11/2000	CSS-100	INV-A123	ITTT-100/AS-1	200
3	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	100
4	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	40
5	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	50
6	TOTAL				190
7
8
9	DATE	CUSTOMER	INV NO	ITEM	QTY
10	11/12/2000	CSS-100	INV-A123	ITTT-100/AS-2	300
11	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-2	400
12	TOTAL				400
OUTPUT

thanks

 

[Alex Blakenburg]

When I run Peter's code on your sample data the items remaining are shown below and consists of 2 small ranges.
What this means is that although the size looks large at 40,445 rows 40,440 of the rows are contiguous that is they are a single block of rows (29 - 40,445) with nothing in between that needs to be kept.
Deleting a single block is not what makes deleting rows a slow process, deleting rows scattered throughout the data set is what is slow,
So unless this is actually the case in your live data, then using this to test performance is not going to give you a representative time.

Using your original Post #1 data and repeating it to fill 60k rows, it takes around 18 secs to run

Result after running the Macro on your sample data:

20230110 VBA Delete Non-Contiguous Formatted rows Maklil v05.xlsm
	A	B	C	D	E	F	G
1	DATE	CUSTOMER	INV NO	ITEM	QTY		Original Row No
2	11/11/2000	CSS-100	INV-A123	ITTT-100/AS-1	200		2
3	7/01/2023	CSS-100	INV-A123	ITTT-100/AS-1	300		3
4	7/01/2023	CSS-100	INV-A123	ITTT-100/AS-1	40		4
5	7/01/2023	CSS-100	INV-A123	ITTT-100/AS-1	50		5
6	TOTAL				390		6
7							7
8							8
9	DATE	CUSTOMER	INV NO	ITEM	QTY		23
10	17/11/2000	CSS-100	INV-A129	ITTT-100/AS-7	800		24
11	7/01/2023	CSS-100	INV-A129	ITTT-100/AS-7	900		25
12	TOTAL				100		26
13							27
14							28
15
16
17
OUTPUT

 

[Alex Blakenburg]

If you do discover the performance issue I am referring, try the code below.
It reduces the 18 secs on a more realistic set of data (60k rows) down to 5 and if you don't have any formulas in your "DETAIL" sheet you can swap out the Paste:=xlPasteFormulas with Paste:=xlPasteValues, which will reduce it to under 3 secs.

This is based on @Peter_SSs's post 5 which uses the sort method and relies on his very accurate flagging of the rows in a helper column with 1 for to be deleted and importantly Blank for to be retained. The code copies the formatting from the to be retained rows to the post deleted result in the Sheet output.

It works as far as I can tell. Let me know how it goes at your end.

Sub Del_Blocks_PeterPost5_withCopyBorders()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, j As Long, k As Long, fr As Long, rws As Long
  Dim v As Double, tot As Double
  Dim tm As Double
  tm = Timer
  
  With Sheets("DETAILS")
        nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
        a = .Range("E1", .Range("E" & Rows.Count).End(xlUp).Offset(2)).Value
        a(UBound(a) - 1, 1) = "QTY"
        ReDim b(1 To UBound(a), 1 To 1)
      For i = 1 To UBound(a)
        Select Case a(i, 1)
          Case "QTY"
            If rws > 0 Then
              If a(i - 3, 1) = v Or a(i - 3, 1) = 0 Then
                For j = fr To fr + rws - 1
                  k = k + 1
                  b(j, 1) = 1
                Next j
              End If
            End If
            fr = i
            v = a(i + 1, 1)
            rws = 1
          Case Else
            rws = rws + 1
        End Select
      Next i
        
      If k > 0 Then
        Application.ScreenUpdating = False
       
        Application.DisplayAlerts = False
        On Error Resume Next
        Sheets("OUTPUT").delete
        On Error Resume Next
        Application.DisplayAlerts = True
         
        With .Range("A1").Resize(UBound(a), nc)
          .Columns(nc).Value = b
          .Columns(nc).SpecialCells(xlBlanks).EntireRow.Copy
        End With
        
        Dim outSht As Worksheet
        Set outSht = Sheets.Add
        outSht.Name = "OUTPUT"
    
        With .Range("A1").Resize(UBound(a), nc)
            .Copy
            outSht.Range("A1").PasteSpecial Paste:=xlPasteFormulas
        End With
    
        
        With outSht.Range("A1").Resize(UBound(a), nc)
          .Range("A1").PasteSpecial Paste:=xlPasteFormats
          .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
          .Resize(k).EntireRow.delete
        End With
        
        With .Range("A1").Resize(UBound(a), nc)
            .Columns(nc).SpecialCells(xlBlanks).EntireRow.Copy
        End With
    
        outSht.Range("A1").PasteSpecial Paste:=xlPasteFormats
        .Columns(nc).ClearContents
        
        .Columns("A").Resize(, nc - 1).Copy
        Sheets("Output").Columns("A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.ScreenUpdating = True
      End If
  End With
  MsgBox Format(Timer - tm, "0.00")
End Sub

 

[Maklil]

@Alex Blakenburg
thanks for clarification.
I will try your way today later and inform you what happens.

 

[bebo021999]

@bebo021999 thanks
it doesn't seem to work !

1) Below image is after code. Could you point the error out?

2) BTW, to dupplicate sheet without button, I use:

Application.CopyObjectsWithCells = False
'copy
Application.CopyObjectsWithCells = True

And the final code should be:

Option Explicit


Sub delRange()
Dim lr&, i&, j&, t&, seri, rng
Dim tm As Double
  tm = Timer
Application.CopyObjectsWithCells = False
Sheets("DETAILS").Copy after:=Sheets("DETAILS") ' dupplicate sheet DETAILS
If Evaluate("=ISREF(OUTPUT!A1)") Then Sheets("OUTPUT").Delete ' delete the old OUTPUT sheet
ActiveSheet.Name = "OUTPUT"
Application.CopyObjectsWithCells = True
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A1:F" & lr).Value
For i = 1 To UBound(rng) - 1
   If rng(i, 1) = "DATE" Then
        For j = i + 1 To UBound(rng)
            If rng(j, 1) = "TOTAL" Then
                If rng(j, 5) <> 0 And rng(j, 5) <> rng(i + 1, 5) Then
                    For t = i To IIf(j >= UBound(rng), UBound(rng), j + 2)
                        seri = seri + 1
                        rng(t, 6) = seri
                    Next
                    i = j + 1
                End If
                Exit For
            End If
        Next
    End If
Next
With Range("A1").Resize(UBound(rng), 6)
    .Value = rng
    .Sort Range("F1")
End With
lr = Cells(Rows.Count, "F").End(xlUp).Row
Range(Cells(lr + 1, 1), Cells(Rows.Count, 1)).EntireRow.Delete
Columns("F").ClearContents
MsgBox "Done!"
MsgBox Format(Timer - tm, "0.00")
End Sub

 

[Maklil]

@bebo021999
thanks nothing changes .

1) Below image is after code. Could you point the error out?

didy you see missed borders for row3,4 and the TOTAL row border becomes to bottom in row7 and add wrong border in row2 ? the right way as in range row9:12 as in picture . your code makes the TOTAL row border to bottom .

 

[Peter_SSs]

1) Below image is after code. Could you point the error out?

Row 2 has a heavy border that should not be there.
Rows 3 and 4 do not have internal borders at all.
Row 7 has the heavy border that should be on row 6.
As Alex has pointed out the borders issue related to sorting.

Edit: Oops, missed @Maklil post above so ignore my repetition above.

@Alex Blakenburg
I think that something is wrong with your code. Haven't looked at the cause in detail but I suspect it could relate to the fact that the initial blocks are not evenly spaced - see before image in post #15

In any case, I have found this alternative code faster than others suggested and retains formatting. At this stage I have assumed that original data has at least two blank rows between each block.

Sub Del_Blocks_v4()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, j As Long, k As Long, fr As Long, rws As Long
  Dim v1 As Double, v2 As Double
 
  Dim tm As Double
  tm = Timer
 
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("OUTPUT").Delete
  On Error Resume Next
  Application.DisplayAlerts = True
  Sheets.Add(after:=Sheets("DETAILS")).Name = "OUTPUT"
  With Sheets("DETAILS")
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range("E1", .Range("E" & Rows.Count).End(xlUp).Offset(2)).Value
    a(UBound(a) - 1, 1) = "QTY"
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      Select Case a(i, 1)
        Case "QTY"
          If rws > 0 Then
            If v1 <> v2 And v2 <> 0 Then
              For j = fr To fr + rws - 1
                k = k + 1
                b(j, 1) = 1
              Next j
            End If
          End If
          fr = i
          v1 = a(i + 1, 1)
          rws = 1
        Case vbNullString
          If a(i - 2, 1) <> "" Then rws = rws + 1
        Case Else
          v2 = a(i, 1)
          rws = rws + 1
      End Select
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Cells(1, nc).Resize(UBound(a))
        .Value = b
        .SpecialCells(xlConstants).EntireRow.Copy Destination:=Sheets("OUTPUT").Range("A1")
        .ClearContents
      End With
      Sheets("OUTPUT").Cells(1, nc).Resize(k).ClearContents
      Sheets("OUTPUT").UsedRange.EntireColumn.AutoFit
      Application.ScreenUpdating = True
    End If
  End With
  MsgBox Format(Timer - tm, "0.00")
End Sub

I used this sample data copied down 6,000 rows.

Maklil.xlsm
	A	B	C	D	E
1	DATE	CUSTOMER	INV NO	ITEM	QTY
2	11/11/2000	CSS-100	INV-A123	ITTT-100/AS-1	200
3	1/07/2023	CSS-100	INV-A123	ITTT-100/AS-1	300
4	1/07/2023	CSS-100	INV-A123	ITTT-100/AS-1	40
5	1/07/2023	CSS-100	INV-A123	ITTT-100/AS-1	50
6	TOTAL				200
7
8
9	DATE	CUSTOMER	INV NO	ITEM	QTY
10	11/12/2000	CSS-100	INV-A123	ITTT-100/AS-2	300
11	1/07/2023	CSS-100	INV-A123	ITTT-100/AS-2	40
12	1/07/2023	CSS-100	INV-A123	ITTT-100/AS-2	50
13	TOTAL				0
14
15
16
17
18	DATE	CUSTOMER	INV NO	ITEM	QTY
19	11/15/2000	CSS-100	INV-A124	ITTT-100/AS-2	600
20	1/07/2023	CSS-100	INV-A124	ITTT-100/AS-2	200
21	1/07/2023	CSS-100	INV-A124	ITTT-100/AS-2	400
22	TOTAL				20
23
24
25	DATE	CUSTOMER	INV NO	ITEM	QTY
26	11/17/2000	CSS-100	INV-A129	ITTT-100/AS-7	800
27	1/07/2023	CSS-100	INV-A129	ITTT-100/AS-7	900
28	TOTAL				100
29
30
31
32
33	DATE	CUSTOMER	INV NO	ITEM	QTY
34	5/07/2003	CSS-1000	INV-A1030	ITTT-100/AS-902	2493
35	1/07/2023	CSS-1000	INV-A1030	ITTT-100/AS-902	1000
36	1/07/2023	CSS-1000	INV-A1030	ITTT-100/AS-902	400
37	1/07/2023	CSS-1000	INV-A1030	ITTT-100/AS-902	1000
38	1/07/2023	CSS-1000	INV-A1030	ITTT-100/AS-902	93
39	TOTAL				2493
40
41
42	DATE	CUSTOMER	INV NO	ITEM	QTY
43	5/08/2003	CSS-1001	INV-A1031	ITTT-100/AS-903	2494
44	TOTAL				2494
45
46
47	DATE	CUSTOMER	INV NO	ITEM	QTY
48	5/09/2003	CSS-1002	INV-A1032	ITTT-100/AS-904	2495
49	TOTAL				2495
50
51
52
53
54
55
56	DATE	CUSTOMER	INV NO	ITEM	QTY
57	5/10/2003	CSS-1003	INV-A1033	ITTT-100/AS-905	2496
58	TOTAL				200
59
60
DETAILS

Formatting of original sheet shown here

First part of my OUTPUT sheet shown here.

 

[Maklil]

@Alex Blakenburg

just question, did you test your modfying?
it doesn't show me anything!
if I said you strange thing , do you surprise from that?
in reality when test the data contains different count rows for each range whether they locates consecutively to the bottom ( following one after another without an interruption or not )the code becomes faster than before.
yesterday gives 0.530 sec
today gives 0.03 for two both codes post#26 & 36 from the first time, after run the macro more than one time the first will give 0.260 sec
second give 0.110 sec

I no know if it's relating for LAPTOP's memory .

 

[Maklil]

@Peter_SSs

again thanks for new version . I can depend on two codes
just I have problem about autofit the columns width , some data don't show clearly for the last code . I have to expanding columns width manually . can the code does it without interfering from me ?
date is not clear and data in column D

Merging ranges.xlsb
	A	B	C	D	E
1	DATE	CUSTOMER	INV NO	ITEM	QTY
2	########	CSS-100	INV-A123	ITTT-100/AS-1	200
3	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	300
4	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	40
5	1/7/2023	CSS-100	INV-A123	ITTT-100/AS-1	50
6	TOTAL				390
7
8
9	DATE	CUSTOMER	INV NO	ITEM	QTY
10	########	CSS-100	INV-A129	ITTT-100/AS-7	800
11	1/7/2023	CSS-100	INV-A129	ITTT-100/AS-7	900
12	TOTAL				100
13
14
15	DATE	CUSTOMER	INV NO	ITEM	QTY
16	########	CSS-1152	INV-A1182	ITTT-100/AS-1054	2645
17	########	CSS-1153	INV-A1183	ITTT-100/AS-1055	2646
18	TOTAL				2647
19
20
21	DATE	CUSTOMER	INV NO	ITEM	QTY
22	########	CSS-1411	INV-A1441	ITTT-100/AS-1313	2904
23	########	CSS-1412	INV-A1442	ITTT-100/AS-1314	2905
24	########	CSS-1413	INV-A1443	ITTT-100/AS-1315	2906
25	########	CSS-1414	INV-A1444	ITTT-100/AS-1316	2907
26	########	CSS-1415	INV-A1445	ITTT-100/AS-1317	2908
27	TOTAL				2905
28
29
OUTPUT

 

[Peter_SSs]

just I have problem about autofit the columns width ,

Just add this blue line of code where indicated near the end of the previous code.

Sheets("OUTPUT").Cells(1, nc).Resize(k).ClearContents
Sheets("OUTPUT").UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True

 

[Maklil]

@Peter_SSs I bet this tread took much more time to solve it especially yesterday .
thanks for your time and solution .