Help on making this code Run faster, Takes like a minute

[DarrenBurke]

Hi, Guys and gals,
Can i tweak this code to run faster.
What are you trying to do ? I want the code to check colum "A" for empty cells and delete the entire row. (Basically the telesales did not capture the correct info, therefore the row of info is useless and needs to be deleted. ) It works as is but takes a long time to finish. I have 10 other sheets to apply it to with a macro on each sheet. Thank you to the Hive Minds

Sub Delete_Rows_with_Blank_Cells_in_Single_Column()

Worksheets("MichaelF").Activate

Set Rng = ActiveSheet.UsedRange

Blank_Cells_Column = 1

For i = Rng.Rows.Count To 1 Step -1
    If Rng.Cells(i, Blank_Cells_Column) = "" Then
        Rng.Cells(i, Blank_Cells_Column).EntireRow.Delete
    End If
Next i
   
End Sub

I hope i did the code correctly

Cheers

 

[DarrenBurke]

Thank you so much Peter it works in milliseconds.... WOW!!
Thank you Fluff, Both Champions
Cheers from a chilly South Africa

Hi Peter, Sorry , The code runs perfect, when clicked on, removes all empty cells and the associated row. If you click it a second time without closing and opening the workbook it gives an error.... a bit like saying " i have done my bit what now lol" I will send a snapshot , Thank you for your help.

 

[Peter_SSs]

I don't think it is related to closing or opening the workbook.
From your image, it looks like the table is empty. I'm wondering why you are running the code again, particularly if the table is already empty?

 

[DarrenBurke]

I don't think it is related to closing or opening the workbook.
From your image, it looks like the table is empty. I'm wondering why you are running the code again, particularly if the table is already empty?

100 % correct, it had empty lines when first run. and it cleared them. I will diasable the button after click and set "msgbox The Blank Lines Have been Cleared" ...... when workbook reopens the button click will be active again for one click again. Humans are in curios by design LOL. Thank you. Ps,, Louise's sheet had 3 records captured 2 blank rows (these were deleted and one record captured) she has only one row of information at the moment, see snapshot.

how it works.
When the workbook opens, the data connections run(Automatically) and fetch any new captured info. this is then placed in the individual green sheet tabs at the bottom.
The manager then clicks the top left Button in red. This clears the sheet and and also clears any blank rows in the green sheet tabs. Then She clicks on "Fetch that new info"

I think i will upload the mini worksheet, then you can see it in action, just ignore the data connecion errors.
It only fails when the sheet has 1 record in it( Louise is a newbie and finding her feet)

GetdatafromFundRaisers.xlsm
	B	C	D	E	F	G	H	I	J	K	L
1					Jacqui's Data	Mariana's Data	Trevor's Data	Suzette's Data	Kasia's Data	Sean
2					Kevin's Data	Ruth's Data	Kerry-Lee's Data	Theresa's Data	Louise's Data
3	Captured	REP	CODE	P/U DATE	COMPANY	ADDRESS	X-ROAD/SUBURB	AREA	AMOUNT	Drivers
4
5	2022-06-16	MF	1		SUPA QUICK EDENVALE	C/R 10 TH STR	EDENVALE	EDENVALE
6	2022-06-16	MF	1		TALLISMAN HIRE BENONI	92 GOUSBLOM STR	NORTHMEAD	BENONI
7	2022-06-16		1
8	2022-06-14	MF	3000	2022-06-15	FAME FENCE(PTY)LTD	180 BROADWALK STR		MIDRAND
9	2022-06-14	MF	318	2022-06-15	NORTH LAWNMOWERS	709 PRESIDENT STEYN STR		PRETORIA
10	2022-06-13	MF	316	2022-06-14	ROSE LIEBENBERG	C/R 10 TH STR	EDENVALE	EDENVALE	R200,00
11	2022-06-13	MF	314	2022-06-14	SCOTSMAN ICE SYSTEMS	18 YALDWYN ROAD	JETPARK	BOKSBURG
12	2022-06-08	MF	301	2022-06-09	LUV MOR MUSIC	1 5TH AVE	MELVILLE	JOHANNESBURG	R200,00
13	2022-06-08	MF	303	2022-06-09	IRENE SAUNDERS	87 RADIO STR	0	ALBERTON	R200,00
14	2022-06-08	MF	304	2022-06-09	LYNS PRE-SCHOOL	CNR PITTS + KORHAAN STREET	SUNNYRIDGE	PRIMROSE	R100,00
15	2022-06-07	MF	299	2022-06-09	GRAYTEX METALS	375 KRUGER STREET	STRIJOMPARK	RANDBURG	R400,00
16	2022-06-07	MF	296	2022-06-09	JMR TRAILERPARTS GAUTENG(PTY)LTD	4 BORAX STREET	ALRODE	ALBERTON	R400,00
17	2022-06-07	MF	297	2022-06-09	ISA VAN SCHALKWYK	1 BRUTON AVENUE	0	BRYANSTON	R400,00
18	2022-06-07	MF	298	2022-06-09	ALMECH PTY LTD	23 GOLDEN DRIVE	MOREHILL	BENONI	R4 800,00
19	2022-06-02	MF	287	2022-06-03	SCOTSMAN ICE SYSTEMS	18 YALDWYN ROAD	JETPARK	BOKSBURG	R500,00
20	2022-06-01	MF	292	2022-06-02	CAR CLINIC	49 SHAFT ROAD	KNIGHTS	GERMISTON	R100,00
21	2022-05-31	MF	288	2022-06-01	MARK MELTZER	57 LAKE RD	CARTER AGENCIES(PTY)LTD	EDENVALE	R550,00
22	2022-05-31	MF	289	2022-06-01	AUTOBAR	688 SECCILL AVE	GEZINA	PTA	R500,00
23	2022-05-31	MF	290	2022-06-01	M & M HYDRAULICS CC	27A GOLDEN DRIVE.	MOREHILL	BENONI	R100,00
24	2022-05-30	MF	1282	2022-05-31	MUGG AND BEAN	H/V NELMAPIUS&	0	PRETORIA	R500,00
25	2022-05-30	MF	1281	2022-05-31	CARLOS DA COSTA	28 LOWTHER STREET	WITFIELD	BOKSBURG	R100,00
26	2022-05-30	MF	278	2022-05-31	TOTAL CAMPBELLS	333 HARRY GALAUN DRIVE	VORNA VALLEY	MIDRAND	R200,00
27	2022-05-30	MF	280	2022-05-31	LANDYTECH	1 TILE RD	ANDERBOLT	BOKSBURG	R200,00
28	2022-05-24	MF	275	2022-05-25	GRAYTEX METALS	375 KRUGER STREET	STRIJOMPARK	RANDBURG	R200,00
29	2022-05-24	MF	276	2022-05-25	EASYLIFE KITCHEN	9 COMMERCE CRESENT	EASTGATE EXT	SANDTON	R300,00
30	2022-05-24	MF	277	2022-05-25	ISA VAN SCHALKWYK	1 BRUTON AVENUE	0	BRYANSTON	R600,00
31	2022-05-23	MF	274	2022-05-25	NTT ISUZU TZANEEN	77 OLD GRAVELOTTE RD		TZANEEN	R600,00
32	2022-05-23	MF	273	2022-05-24	UPPER DECK SPORTS CAFE&BISTRO	CNR PIET RETIEF ROAD		NELSPRUIT	R300,00
CodeT

Cells with Data Validation
Cell	Allow	Criteria
K3	List	=#REF!

 

[DarrenBurke]

Sorry did not copy the buttons this is what it looks like

 

[Peter_SSs]

If you wanted the code to deal with already cleared tables, or tables with only one data row (that is what caused the error you reported previously) yo could try this version.

Sub Del_Rws_v2()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long, Blank_Cells_Column As Long
  
  Blank_Cells_Column = 1
  
  With Sheets("MichaelF").ListObjects(1)
    If .DataBodyRange.Rows.Count > 1 Then
      a = .DataBodyRange.Columns(Blank_Cells_Column).Value
      ReDim b(1 To UBound(a), 1 To 1)
      For i = 1 To UBound(a)
        If Len(a(i, 1)) = 0 Then
          b(i, 1) = 1
          k = k + 1
        End If
      Next i
      If k > 0 Then
        Application.ScreenUpdating = False
        .ListColumns.Add
        With .DataBodyRange
          nc = .Columns.Count
          .Columns(nc).Value = b
          .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlYes
          .Resize(k).EntireRow.Delete
        End With
        .ListColumns(nc).Delete
        Application.ScreenUpdating = True
      End If
    Else
      If Len(.DataBodyRange.Cells(1, Blank_Cells_Column).Value) = 0 Then .DataBodyRange.ClearContents
    End If
  End With
End Sub

 

[Alex Blakenburg]

In the version I was playing around with I had the additional If statement below, to stop it erroring out when the Table had been totally cleared.

    With Sheets("MichaelF").ListObjects(1)
        ' Check for an empty table
        If .DataBodyRange Is Nothing Then Exit Sub

 

[DarrenBurke]

If you wanted the code to deal with already cleared tables, or tables with only one data row (that is what caused the error you reported previously) yo could try this version.

Sub Del_Rws_v2()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long, Blank_Cells_Column As Long
 
  Blank_Cells_Column = 1
 
  With Sheets("MichaelF").ListObjects(1)
    If .DataBodyRange.Rows.Count > 1 Then
      a = .DataBodyRange.Columns(Blank_Cells_Column).Value
      ReDim b(1 To UBound(a), 1 To 1)
      For i = 1 To UBound(a)
        If Len(a(i, 1)) = 0 Then
          b(i, 1) = 1
          k = k + 1
        End If
      Next i
      If k > 0 Then
        Application.ScreenUpdating = False
        .ListColumns.Add
        With .DataBodyRange
          nc = .Columns.Count
          .Columns(nc).Value = b
          .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlYes
          .Resize(k).EntireRow.Delete
        End With
        .ListColumns(nc).Delete
        Application.ScreenUpdating = True
      End If
    Else
      If Len(.DataBodyRange.Cells(1, Blank_Cells_Column).Value) = 0 Then .DataBodyRange.ClearContents
    End If
  End With
End Sub

Thank you Peter, i will give it a spin, let you know.

 

[DarrenBurke]

Thank you Peter, i will give it a spin, let you know.

Perfect Peter. Thank you and God Bless

 

[Peter_SSs]

Perfect Peter. Thank you and God Bless

You're welcome. Thanks for the confirmation.