Delete ranges based on header contains colon and matched with cell value

[abdo meghari]

Hello
I want delete range contains header and matched with cell I3 and also delete from SUMMARY range is matched by part of item with cell I3.
data could be 7000 rows as maximum and 10 ranges as maximum.
example :

KashfMabiatReport1.xls
	A	B	C	D	E	F	G	H	I
1
2				MOVEMENT : PURCHASING
3	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL		MOVEMENT : SELLING
4	2024.01.02	114	1284	GC 1200R20 AZ0026 CHI	80	895.000	242,560.000
5			1285	GC 1200R20 AZ0183 CHI	40	925.000
6			1385	GC 315/80R22.5 AT161 CHI	20	735.000
7			1287	GC 315/80R22.5 AZ126 CHI	20	735.000
8			1294	GC 315/80R22.5 AZ188 CHI	20	745.000
9			1241	BS 1200R20 G580 JAP	40	2,035.000
10			1227	BS 215/70R15C R623 THI	8	425.000
11			1221	BS 205/70R15C R623 THI	12	405.000
12	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
13	2024.01.09	121	1306	BS 750R16 R230 JAP	80	715.000	114,840.000
14			1310	BS 225/95R16C D618 JAP	40	515.000
15			1391	BS 265/65R17 D840 JAP	50	535.000
16			1287	GC 315/80R22.5 AZ126 CHI	14	735.000
17	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
18	2024.01.10	125	1227	BS 215/70R15C R623 THI	2	425.000	850.000
19	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
20	2024.01.17	138	1401	BS 650R16 R230 JAP	5	570.000	5,210.000
21			1402	BS 245/70R16 D697 JAP	4	590.000
22	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
23	2024.01.20	148	1292	GC 1200R24 AZ166 CHI	24	935.000	41,550.000
24			1287	GC 315/80R22.5 AZ126 CHI	26	735.000
25	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
26	2024.01.20	149	1221	BS 205/70R15C R623 THI	50	405.000	411,770.000
27			1227	BS 215/70R15C R623 THI	12	425.000
28			1346	BS 255/70R15C D840	24	505.000
29			1241	BS 1200R20 G580 JAP	180	2,035.000
30			1244	BS 1200R20 R187 JAP	4	2,000.000
31	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
32	2024.01.21	280	1190	BS 285/50R20 DSPORT JAP	1	705.000	11,205.000
33			1411	BS 275/55R20 ALENZA1 JAP	4	725.000
34			1269	BS 1200R24 G580 JAP	4	1,900.000
35	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
36	2024.03.26	215	1306	BS 750R16 R230 JAP	10	940.000	9,400.000
37	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
38	2024.03.30	217	1285	GC 1200R20 AZ0183 CHI	10	1,225.000	12,250.000
39	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
40	2024.04.06	218	1306	BS 750R16 R230 JAP	50	940.000	47,000.000
41	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
42	2024.04.09	226	1227	BS 215/70R15C R623 THI	4	544.000	2,176.000
43	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
44	2024.04.14	230	1285	GC 1200R20 AZ0183 CHI	40	1,205.000	82,320.000
45			1284	GC 1200R20 AZ0026 CHI	30	1,125.000
46			1486	WL 205/55R16 Z-108 CHI	2	185.000
47				MOVEMENT : SELLING
48	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
49	2024.01.24	561	1306	BS 750R16 R230 JAP	10	775.000	7,750.000
50
51
52	SUMMARY
53	TOTAL PURCHASE	980,131.000
54	TOTAL SELLING	7,750.000
55	TOTAL PAID	2,120,485.000
INVOICES

RESULT

KashfMabiatReport1.xls
	A	B	C	D	E	F	G	H	I
1
2				MOVEMENT : PURCHASING
3	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL		MOVEMENT : SELLING
4	2024.01.02	114	1284	GC 1200R20 AZ0026 CHI	80	895.000	242,560.000
5			1285	GC 1200R20 AZ0183 CHI	40	925.000
6			1385	GC 315/80R22.5 AT161 CHI	20	735.000
7			1287	GC 315/80R22.5 AZ126 CHI	20	735.000
8			1294	GC 315/80R22.5 AZ188 CHI	20	745.000
9			1241	BS 1200R20 G580 JAP	40	2,035.000
10			1227	BS 215/70R15C R623 THI	8	425.000
11			1221	BS 205/70R15C R623 THI	12	405.000
12	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
13	2024.01.09	121	1306	BS 750R16 R230 JAP	80	715.000	114,840.000
14			1310	BS 225/95R16C D618 JAP	40	515.000
15			1391	BS 265/65R17 D840 JAP	50	535.000
16			1287	GC 315/80R22.5 AZ126 CHI	14	735.000
17	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
18	2024.01.10	125	1227	BS 215/70R15C R623 THI	2	425.000	850.000
19	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
20	2024.01.17	138	1401	BS 650R16 R230 JAP	5	570.000	5,210.000
21			1402	BS 245/70R16 D697 JAP	4	590.000
22	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
23	2024.01.20	148	1292	GC 1200R24 AZ166 CHI	24	935.000	41,550.000
24			1287	GC 315/80R22.5 AZ126 CHI	26	735.000
25	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
26	2024.01.20	149	1221	BS 205/70R15C R623 THI	50	405.000	411,770.000
27			1227	BS 215/70R15C R623 THI	12	425.000
28			1346	BS 255/70R15C D840	24	505.000
29			1241	BS 1200R20 G580 JAP	180	2,035.000
30			1244	BS 1200R20 R187 JAP	4	2,000.000
31	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
32	2024.01.21	280	1190	BS 285/50R20 DSPORT JAP	1	705.000	11,205.000
33			1411	BS 275/55R20 ALENZA1 JAP	4	725.000
34			1269	BS 1200R24 G580 JAP	4	1,900.000
35	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
36	2024.03.26	215	1306	BS 750R16 R230 JAP	10	940.000	9,400.000
37	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
38	2024.03.30	217	1285	GC 1200R20 AZ0183 CHI	10	1,225.000	12,250.000
39	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
40	2024.04.06	218	1306	BS 750R16 R230 JAP	50	940.000	47,000.000
41	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
42	2024.04.09	226	1227	BS 215/70R15C R623 THI	4	544.000	2,176.000
43	DATE	INVOICE NO	CODE	BRAND	QTY	UNIT PRICE	TOTAL
44	2024.04.14	230	1285	GC 1200R20 AZ0183 CHI	40	1,205.000	82,320.000
45			1284	GC 1200R20 AZ0026 CHI	30	1,125.000
46			1486	WL 205/55R16 Z-108 CHI	2	185.000
47
48
49	SUMMARY
50	TOTAL PURCHASE	980,131.000
51	TOTAL PAID	2,120,485.000
INVOICES

thanks

 

[DanteAmor]

Try this:

Sub deleterange()
  Dim ar As Range, f As Range, r As Range, rng As Range
  Dim i As Long, lr As Long
  Dim itm As String, cell As String
  
  lr = Range("A" & Rows.Count).End(3).Row
  Set rng = Range("A" & lr + 1).Resize(1, 7)
  
  itm = Trim(Split([I3].Value, ":")(1))
  Set r = Range("A:A")
  Set f = r.Find(itm, , xlValues, xlPart, , , False)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      Set rng = Union(rng, f.Resize(1, 7))
      Set f = r.FindNext(f)
    Loop While f.Address <> cell
  End If
  
  Set r = Range("D:D")
  Set f = r.Find([I3], , xlValues, xlWhole, , , False)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      For i = f.Row + 2 To lr
        Select Case Range("D" & i).Value
          Case "", "BRAND", [I3]
            i = i - 1
            Exit For
        End Select
      Next
      Set ar = Range("C" & f.Row + 1, Range("C" & i)).SpecialCells(xlCellTypeConstants)
      Set rng = Union(rng, ar.Offset(-1, -2).Resize(ar.Rows.Count + 1, 7))
      Set f = r.FindNext(f)
    Loop While f.Address <> cell
  End If
  
  Application.ScreenUpdating = False
  rng.Select
  rng.Delete Shift:=xlUp
  Application.ScreenUpdating = False
End Sub

 

[abdo meghari]

Hi Dante ,again .
I'm not sure why don't delete if I write MOVEMENT : PURCHASING , it just delete header without range also will delete rows52:55 for SUMMARY range !
and when write MOVEMENT : SELLING then it's ok except one thing will not delete row 54 as show in result .
row 54 will contain selling should match wit I3 MOVEMENT : SELLING then should delete from SUMMARY range.

 

[DanteAmor]

It is not clear where is the end of the range to delete.

Try this:

Sub deleterange()
  Dim ar As Range, f As Range, r As Range, rng As Range
  Dim i As Long, lr As Long
  Dim itm As String, cell As String
 
  lr = Range("A" & Rows.Count).End(3).Row
  Set rng = Range("A" & lr + 1).Resize(1, 7)
 
  itm = WorksheetFunction.Trim(Split([I3].Value, ":")(1))
  Set r = Range("A:A")
  Set f = r.Find(itm, , xlValues, xlPart, , , False)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      Set rng = Union(rng, f.Resize(1, 7))
      Set f = r.FindNext(f)
    Loop While f.Address <> cell
  End If
 
  Set r = Range("D:D")
  Set f = r.Find([I3], , xlValues, xlWhole, , , False)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      For i = f.Row + 2 To lr
        If Range("D" & i).Value = "" Or InStr(1, Range("D" & i).Value, ":") > 0 Then
          i = i - 1
          Exit For
        End If
      Next
      Set ar = Range("C" & f.Row + 1, Range("C" & i)).SpecialCells(xlCellTypeConstants)
      Set rng = Union(rng, ar.Offset(-1, -2).Resize(ar.Rows.Count + 1, 7))
      Set f = r.FindNext(f)
    Loop While f.Address <> cell
  End If
 
  Application.ScreenUpdating = False
  'rng.Select
  rng.Delete Shift:=xlUp
  Application.ScreenUpdating = False
End Sub

I'm not sure why don't delete if I write MOVEMENT : PURCHASING , it just delete header without range also will delete rows52:55 for SUMMARY range !
and when write MOVEMENT : SELLING then it's ok except one thing will not delete row 54 as show in result .
row 54 will contain selling should match wit I3 MOVEMENT : SELLING then should delete from SUMMARY range.

Check that "Selling" is spelled correctly and also does not contain spaces after the word.

And another thing, in the case of "Purchasing", it is not the same as "Purchase"


Try again and tell me.

 

[abdo meghari]

sorry about error in spelling!
ok this is better , but I need fixing problem deletion the whole summary range .
if I delete one of them based on I3 then should keep the others , but the code will delete all of cells for SUMMARY range.
example: when delete TOTAL SELLING then should keep TOTAL PURCHASE, TOTAL PAID. under SUMMARY word.

It is not clear where is the end of the range to delete.

finally I don't understand this statement until I answer you.

thanks again

 

[DanteAmor]

sorry about error in spelling!

First, on I3 you should have something like this: MOVEMENT : SELLING , just as you put it in your initial example.

Second, the range of cells to delete starts where the text: "MOVEMENT : SELLING" exists, but you are not explaining where the range of rows to delete ends. I'm assuming where it ends, but to make it work check the following image:

Let's test before deleting rows. In the macro, change this line:

rng.Delete Shift:=xlUp

For this line:

rng.Select

So based on the above, try the macro again and tell me what it selects.

If the selected data is not what should be deleted, then, put an image here so that I can see what is selected, and in another image, put what should be deleted.
It is important that the images shows what you have in I3.

 

[abdo meghari]

based on your instruction in post#6 works greatly .
sorry buddy about confusion
every thing is ok now.
thank you so much.