Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

Better way to write this sub, very slow.

0

Hi,

I have written the following sub/s and they seems quite slow even though currently not a great deal of data contained with the workbook. Would you be able to see where I could improve my code please:

Users copy and paste data and mess up the conditional formats/formulas so I reappy them on protected table (formulas locked, data entry fields unlocked)

Sub Resize_Table_Static_Range(Optional sSheet As String)          Dim wb As Workbook     Dim ws As Worksheet     Dim sName, strPass As String     Dim loTable As ListObject     Dim iRow, iCol, irowAfter As Long          Set wb = ActiveWorkbook          If sSheet = "" Then     sSheet = ActiveSheet.Name     End If          Select Case sSheet              Case "worker"             sName = "worker_Table"             Set ws = wb.Sheets(sSheet)             iCol = 23                      Case "Service User - care"             sName = "care_Table"             Set ws = wb.Sheets(sSheet)             iCol = 20                  Case "Service User - Other"             sName = "Other_Table"             Set ws = wb.Sheets(sSheet)             iCol = 18     End Select          Set loTable = ws.ListObjects(sName)          strPass = "pass789"     Set ws = wb.Sheets(sSheet)     iRow = ws.Columns(1).Find(What:="*", searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row          If iRow = 5 Then     ws.Unprotect Password:=strPass     loTable.Resize Range(ws.Cells(5, 1), ws.Cells(6, iCol))     Range(ws.Cells(7, 1), ws.Cells(1000, iCol)).EntireRow.Delete     Call CountConditionallyFormattedCells(sName, ws, iRow)     Call DeleteBlankRows(sName, ws)     Call ReApplyFormatting(sName, ws, iRow, strPass)          With ws             .Protect Password:=strPass, AllowFiltering:=True, AllowSorting:=True, userinterfaceonly:=True             .EnableAutoFilter = True             .EnableSelection = xlNoRestrictions     End With     Exit Sub     Else     ws.Unprotect Password:=strPass     loTable.Resize Range(ws.Cells(5, 1), ws.Cells(iRow, iCol))     Call CountConditionallyFormattedCells(sName, ws, iRow)     Call DeleteBlankRows(sName, ws)     Call ReApplyFormatting(sName, ws, iRow, strPass)     irowAfter = ws.Cells.Find(What:="*", searchdirection:=xlPrevious, SearchOrder:=xlByRows).Row         If irowAfter > iRow Then             If ws.ProtectContents = True Then ws.Unprotect Password:=strPass         Range(ws.Cells(iRow + 1, 1), ws.Cells(irowAfter, iCol)).EntireRow.Delete         End If         With ws             .Protect Password:=strPass, AllowFiltering:=True, AllowSorting:=True, userinterfaceonly:=True             .EnableAutoFilter = True             .EnableSelection = xlNoRestrictions         End With     End If  

End Sub

Sub ReApplyFormatting(sName, ws, iRow, strPass) Dim fc As FormatCondition Dim strFormula As String   ws.Unprotect Password:=strPass ws.Cells.FormatConditions.Delete       Select Case ws.Name              Case "worker"                  strFormula = "=AND($A6<>"""",$G6="""")"         If iRow > 6 Then             Set fc = Range(ws.Cells(6, 7), ws.Cells(iRow, 7)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 7), ws.Cells(6, 7)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$i6="""")"         If iRow > 6 Then             Set fc = Range(ws.Cells(6, 9), ws.Cells(iRow, 9)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 9), ws.Cells(6, 9)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$m6="""")"         If iRow > 6 Then             Set fc = Range(ws.Cells(6, 13), ws.Cells(iRow, 13)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 13), ws.Cells(6, 13)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$n6="""")"         If iRow > 6 Then             Set fc = Range(ws.Cells(6, 14), ws.Cells(iRow, 14)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 14), ws.Cells(6, 14)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$o6="""")"         If iRow > 6 Then             Set fc = Range(ws.Cells(6, 15), ws.Cells(iRow, 15)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 15), ws.Cells(6, 15)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$v6="""")"         If iRow > 6 Then         Set fc = Range(ws.Cells(6, 22), ws.Cells(iRow, 22)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)         fc.Interior.Color = RGB(244, 113, 116)         fc.Font.Color = RGB(255, 255, 255)         Else         Set fc = Range(ws.Cells(6, 22), ws.Cells(6, 22)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)         fc.Interior.Color = RGB(244, 113, 116)         fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$w6="""")"         If iRow > 6 Then             Set fc = Range(ws.Cells(6, 23), ws.Cells(iRow, 23)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 23), ws.Cells(6, 23)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=$D6=""Closed"""         If iRow > 6 Then             Set fc = Range(ws.Cells(6, 1), ws.Cells(iRow, 23)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(166, 166, 166)             Else             Set fc = Range(ws.Cells(6, 1), ws.Cells(6, 23)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(166, 166, 166)         End If                  strFormula = "=COUNTIFS($A$6:$A$" & iRow & ","">=""&A6-30,$A$6:$A$" & iRow & ",""<=""&A6+30,$G$6:$G$" & iRow & ",""=""&G6)>1"         If iRow > 6 Then             Set fc = Range(ws.Cells(6, 7), ws.Cells(iRow, 7)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(255, 255, 0)             Else             Set fc = Range(ws.Cells(6, 7), ws.Cells(iRow, 7)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(255, 255, 0)         End If                  'reapply formulas         ws.Cells(6, 2).Formula = "=IF([@[Date entry created]]="""","""",Overview!$C$5)"         If iRow > 6 Then ws.Range(ws.Cells(6, 2), ws.Cells(iRow, 2)).FillDown                     ws.Cells(6, 4).Formula = "=IF([@[Date entry created]]="""","""",IF([@[Date case closed]]>0,""Closed"",""Open""))"         If iRow > 6 Then ws.Range(ws.Cells(6, 4), ws.Cells(iRow, 4)).FillDown                  'new******         ws.Cells(6, 5).Formula = "=row()"         If iRow > 6 Then ws.Range(ws.Cells(6, 5), ws.Cells(iRow, 5)).FillDown         'new******                  ws.Cells(6, 6).Formula = "=IF([@[Date entry created]]="""","""",IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!$A$2:$B$135,2,FALSE),IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!$C$2:$D$31,2,FALSE),IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!$E$2:$F$27,2,FALSE),IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!$N$2:$O$15,2,FALSE),IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!Q$2:$R$10,2,FALSE),IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!$X$7:$Y$8,2,FALSE),IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!$AA$2:$AB$10,2,FALSE),VLOOKUP(Overview!$C$5,'Establishment codes'!$U$11:$V$11,2,FALSE))))))))&""S""&[@[Get next number]])"         If iRow > 6 Then ws.Range(ws.Cells(6, 6), ws.Cells(iRow, 6)).FillDown                          ws.Cells(6, 19).Formula = "=IF([@[Date isolation started]]="""","""",IF([@[Date case closed]]="""",DAYS(TODAY(),[@[Date isolation started]])+1,""""))"         If iRow > 6 Then ws.Range(ws.Cells(6, 19), ws.Cells(iRow, 19)).FillDown                          Case "Service User - care"         'Array("F", "J", "K", "L", "M") - taken from peter's code         strFormula = "=AND($A6<>"""",$F6="""")"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 6), ws.Cells(6, 6)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 6), ws.Cells(iRow, 6)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$J6="""")"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 10), ws.Cells(6, 10)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 10), ws.Cells(iRow, 10)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$K6="""")"         If iRow = 5 Then         Set fc = Range(ws.Cells(6, 11), ws.Cells(6, 11)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)         fc.Interior.Color = RGB(244, 113, 116)         fc.Font.Color = RGB(255, 255, 255)         Else         Set fc = Range(ws.Cells(6, 11), ws.Cells(iRow, 11)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)         fc.Interior.Color = RGB(244, 113, 116)         fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$L6="""")"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 12), ws.Cells(6, 12)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 12), ws.Cells(iRow, 12)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$M6="""")"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 13), ws.Cells(6, 13)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 13), ws.Cells(iRow, 13)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=$D6=""Closed"""         If iRow = 5 Then         Set fc = Range(ws.Cells(6, 1), ws.Cells(6, 20)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)         fc.Interior.Color = RGB(166, 166, 166)         Else         Set fc = Range(ws.Cells(6, 1), ws.Cells(iRow, 20)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)         fc.Interior.Color = RGB(166, 166, 166)         End If                         strFormula = "=COUNTIFS($A$6:$A$" & iRow & ","">=""&A6-30,$A$6:$A$" & iRow & ",""<=""&A6+30,$f$6:$f$" & iRow & ",""=""&f6)>1"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 6), ws.Cells(6, 6)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(255, 255, 0)             Else             Set fc = Range(ws.Cells(6, 6), ws.Cells(iRow, 6)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(255, 255, 0)         End If                  'reapply formulas         ws.Cells(6, 2).Formula = "=IF([@[Date entry created]]="""","""",Overview!$C$5)"         If iRow > 6 Then ws.Range(ws.Cells(6, 2), ws.Cells(iRow, 2)).FillDown                          ws.Cells(6, 3).Formula = "=IF([@[Date entry created]]="""","""",IF([@[Date case closed]]>0,""Closed"",""Open""))"         If iRow > 6 Then ws.Range(ws.Cells(6, 3), ws.Cells(iRow, 3)).FillDown                  'new******         ws.Cells(6, 5).Formula = "=row()"         If iRow > 6 Then ws.Range(ws.Cells(6, 5), ws.Cells(iRow, 5)).FillDown         'new******                          ws.Cells(6, 5).Formula = "=IF([@[Date entry created]]="""","""",VLOOKUP(Overview!$C$5,'Establishment codes'!$A$2:$B$199,2,FALSE)&""U""&[@[Get next number]])"         If iRow > 6 Then ws.Range(ws.Cells(6, 5), ws.Cells(iRow, 5)).FillDown                          ws.Cells(6, 17).Formula = "=IF([@[Date isolation started]]="""","""",IF([@[Date case closed]]="""",DAYS(TODAY(),[@[Date isolation started]])+1,""""))"         If iRow > 6 Then ws.Range(ws.Cells(6, 17), ws.Cells(iRow, 17)).FillDown                          Case "Service User - Other"         'Array("G", "J", "K") - taken from peter's code         strFormula = "=AND($A6<>"""",$G6="""")"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 7), ws.Cells(6, 7)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 7), ws.Cells(iRow, 7)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=AND($A6<>"""",$J6="""")"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 10), ws.Cells(6, 10)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 10), ws.Cells(iRow, 10)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If           strFormula = "=AND($A6<>"""",$K6="""")"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 11), ws.Cells(6, 11)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)             Else             Set fc = Range(ws.Cells(6, 11), ws.Cells(iRow, 11)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(244, 113, 116)             fc.Font.Color = RGB(255, 255, 255)         End If                  strFormula = "=$D6=""Closed"""         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 1), ws.Cells(6, 18)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(166, 166, 166)             Else             Set fc = Range(ws.Cells(6, 1), ws.Cells(iRow, 18)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(166, 166, 166)         End If                  strFormula = "=COUNTIFS($A$6:$A$" & iRow & ","">=""&A6-30,$A$6:$A$" & iRow & ",""<=""&A6+30,$G$6:$G$" & iRow & ",""=""&G6)>1"         If iRow = 5 Then             Set fc = Range(ws.Cells(6, 7), ws.Cells(6, 7)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(255, 255, 0)             Else             Set fc = Range(ws.Cells(6, 7), ws.Cells(iRow, 7)).FormatConditions.Add(Type:=xlExpression, Formula1:=strFormula)             fc.Interior.Color = RGB(255, 255, 0)         End If                  'reapply formulas         ws.Cells(6, 2).Formula = "=IF([@[Date entry created]]="""","""",Overview!$C$5)"         If iRow > 6 Then ws.Range(ws.Cells(6, 2), ws.Cells(iRow, 2)).FillDown           ws.Cells(6, 4).Formula = "=IF([@[Date entry created]]="""","""",IF([@[Date case closed]]>0,""Closed"",""Open""))"         If iRow > 6 Then ws.Range(ws.Cells(6, 4), ws.Cells(iRow, 4)).FillDown                  'new******         ws.Cells(6, 5).Formula = "=row()"         If iRow > 6 Then ws.Range(ws.Cells(6, 5), ws.Cells(iRow, 5)).FillDown         'new******                          ws.Cells(6, 6).Formula = "=IF([@[Date entry created]]="""","""",IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!$C$2:$D$31,2,FALSE),IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!$N$2:$O$15,2,FALSE),IFNA(VLOOKUP(Overview!$C$5,'Establishment codes'!Q$2:$R$10,2,FALSE),VLOOKUP(Overview!$C$5,'Establishment codes'!$U$11:$V$11,2,FALSE))))&""U""&[@[Get next number]])"         If iRow > 6 Then ws.Range(ws.Cells(6, 6), ws.Cells(iRow, 6)).FillDown                          ws.Cells(6, 15).Formula = "=IF([@[Date isolation started]]="""","""",IF([@[Date case closed]]="""",DAYS(TODAY(),[@[Date isolation started]])+1,""""))"         If iRow > 6 Then ws.Range(ws.Cells(6, 15), ws.Cells(iRow, 15)).FillDown              End Select          ws.Protect Password:=strPass     

End Sub

Thanks you,

Appreciate it!

Cynthia

excelmacros-vbaformattingtable
posted by: Cynthia on Thu May 19, 2022 at 4:55 am
Answer
Discuss

Answers

1

Hi Cynthia and welcome to the Forum.

Firstly, please use the tips shown in Don's tutorail here: Guide to Making Your Macro Run Faster and Better in Excel

Hopefully that helps but, if not, I doubt that anyone has the time or energy to optimise your code (this is a Q & A Forum only). That's less likely since your code in the question is very hard to read. Next time, please press the CODE word (in the bar above the tetx), select only the bit  saying "Code_Goes_Here" and paste a copy of your module code (as plain text). You'll then get a result like this after you submit your question (or Discussion point)...

Sub Resize_Table_Static_Range(Optional sSheet As String)          

Dim wb As Workbook     

Dim ws As Worksheet     

Dim sName, strPass As String     

Dim loTable As ListObject     

Dim iRow, iCol, irowAfter As Long          

Set wb = ActiveWorkbook
'etc........

Also, it often helps if you attach a representative Excel file (without any personal data) to your question. To do that (after, edit your question and), use the Add Files... button to upload  to show your existing macro and data.

Hope this helps.

posted by: John_Ru (rep: 6142) on Thu May 19, 2022 at 7:10 am
Discuss


Answer the Question

You must create an account to use the forum. Create an Account or Login