How to speed up macros/hide screen while code is running - excel

Question

I have a series of macros that format a single sheet and import values from hardcoded arrays if a match is found. The code is well commented. Macros are called in the order that they are listed. I would like your opinion on how to speed up the code or hide the sheet from view, so that the user doesn’t see any manipulation on the screen while Macro is running. Thank you very much.
Sub MacroA()
'
' addcolumn Macro
'
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("QC")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Application.EnableEvents = False
Application.ScreenUpdating = False
'~~~~~> error checking
If Sheet2.Range("A2").Value = "" Then
'MsgBox " There are no QC samples on this run"
Exit Sub
End If
Worksheets("QC").Select
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~copy down value from A2
sht.Range("A2").Value2 = "HD200_QC"
'copy QC name down
Range("A2").Select
Selection.Copy
Range("A2:A" & LastRow).Select
ActiveSheet.Paste
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Columns(3).EntireColumn.Delete 'removes extra column for interpretation
Columns("H:H").Select '\\add one column
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("G:G").Select 'convert formulas to values
Selection.Copy
Columns("G:G").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With sht
.Range("A1").Value2 = "QC"
.Range("G1").Value2 = "AAchange"
.Range("H1").Value2 = "Standard"
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub deleteIrrelevantColumns() 'delete all columns except for the ones with a certain name.
Dim currentColumn As Integer
Dim columnHeading As String
Application.EnableEvents = False
Application.ScreenUpdating = False
'ActiveSheet.Columns("L").Delete
For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value
'CHECK WHETHER TO KEEP THE COLUMN
Select Case columnHeading
Case "QC", "gene", "exon", "cDNA", "AAchange", "%Alt", "Standard"
'Do nothing
Case Else
'Delete if the cell doesn't contain these
If InStr(1, _
ActiveSheet.UsedRange.Cells(1, currentColumn).Value, _
"Matreshkaper", vbBinaryCompare) = 0 Then
ActiveSheet.Columns(currentColumn).Delete
End If
End Select
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub PopulateStandard()
'PURPOSE: Filter on specific values
Dim rng As Range
Dim LastRow, i As Long
Dim GeneCheck As String
Dim vArr As Variant
Dim x
Dim y
'wsQC.Select
Worksheets("QC").Select
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Application.EnableEvents = False
Application.ScreenUpdating = False
vArr = Array(Array("HD300_QCL861Q", "5"), _
Array("HD300_QCE746_E749del", "5"), _
Array("HD300_QCL858R", "5"), _
Array("HD300_QCT790M", "5"), _
Array("HD300_QCG719S", "5"), _
Array("HD200_QCV600E", "10.5"), _
Array("HD200_QCD816V", "10"), _
Array("HD200_QCE746_E749del", "2"), _
Array("HD200_QCL858R", "3"), _
Array("HD200_QCT790M", "1"), _
Array("HD200_QCG719S", "24.5"), _
Array("HD200_QCG13D", "15"), _
Array("HD200_QCG12D", "6"), _
Array("HD200_QCQ61K", "12.5"), _
Array("HD200_QCH1047R", "17.5"), _
Array("HD200_QCE545K", "9"))
For i = 2 To LastRow
GeneCheck = Right(Cells(i, 1).Value, 8) & Cells(i, 5).Value
'//Tell VBA to ignore an error and continue (ie if it can't find the value)
On Error Resume Next
'//Assign the result of your calculation to a variable that VBA can query
x = WorksheetFunction.VLookup(GeneCheck, vArr, 2, False)
'//if Vlookup finds the value, then paste it into the required column
If Err = 0 Then
Cells(i, 6).Value = x
Else
End If
'//resets to normal error handling
On Error GoTo 0
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub MissingValues()
Dim zArr As Variant
Dim yArr As Variant
Dim LastRow As Long
Dim LastRow2 As Long
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("QC")
Application.EnableEvents = False
Application.ScreenUpdating = False
yArr = Array(Array("EGFR", "", "", "L861Q", "5"), _
Array("EGFR", "", "", "KELRE745delinsK", "5"), _
Array("EGFR", "", "", "L858R", "5"), _
Array("EGFR", "", "", "T790M", "5"), _
Array("EGFR", "", "", "G719S", "5"))
zArr = Array(Array("BRAF", "", "", "V600E", "10.5"), _
Array("KIT", "", "", "D816V", "10"), _
Array("EGFR", "", "", "KELRE745delinsK", "2"), _
Array("EGFR", "", "", "L858R", "3"), _
Array("EGFR", "", "", "T790M", "1"), _
Array("EGFR", "", "", "G719S", "24.5"), _
Array("KRAS", "", "", "G13D", "15"), _
Array("KRAS", "", "", "G12D", "6"), _
Array("NRAS", "", "", "Q61K", "12.5"), _
Array("PIK3CA", "", "", "H1047R", "17.5"), _
Array("PIK3CA", "", "", "E545K", "9"))
'Ctrl + Shift + End
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
If InStr(1, ActiveSheet.Range("A2").Value, "HD200") > 0 Then
Sheets("QC").Select
Worksheets("QC").Range("B" & LastRow + 2 & ":F" & LastRow + 12).Value = Application.Index(zArr, 0)
ElseIf InStr(1, ActiveSheet.Range("A2").Value, "HD300") > 0 Then
Sheets("QC").Select
Worksheets("QC").Range("B" & LastRow + 2 & ":F" & LastRow + 6).Value = Application.Index(yArr, 0)
End If
LastRow2 = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
'MsgBox (LastRow2)
Columns("B:G").Select
ActiveSheet.Range("$A$1:$G$" & LastRow2).RemoveDuplicates Columns:=Array(2, 5, 6), _
Header:=xlYes
Range("A1").Select
With Worksheets("QC")
'lRow = .Range("A" & Rows.Count).End(xlUp).Row
.Cells(LastRow + 1, 1).Value = "Removed Low Alts."
End With
Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
Columns("A:G").EntireColumn.AutoFit
Range("A1").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWorkbook.Worksheets("QC").Sort.SortFields.clear
ActiveWorkbook.Worksheets("QC").Sort.SortFields.Add Key:=Range("F2:F" & LastRow), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("QC").Sort
.SetRange Range("A1:G" & LastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Adds a grid around the data
LastRow2 = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
Range("A2:G" & LastRow2).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'~~~~> add yellow color
Range("F2:G" & LastRow2).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 12514808
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'~~~~> make font red
Range("F2:F" & LastRow2).Select
With Selection.Font
.Color = -16777024
.TintAndShade = 0
End With
Range("A1").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub Filter()
'PURPOSE: Filter on specific values
Dim rng As Range
Dim LastRow, i As Long
Dim GeneCheck As String
Dim vArr As Variant
Dim x
Dim y
Dim FilterField As Variant
'wsQC.Select
Worksheets("QC").Select
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Application.EnableEvents = False
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("A1:AC" & LastRow)
FilterField = WorksheetFunction.Match("AAchange", rng.Rows(1), 0)
'Turn on filter if not already turned on
'If ActiveSheet.AutoFilterMode = False Then rng.AutoFilter
If InStr(1, ActiveSheet.Range("A2").Value, "HD200") > 0 Then
rng.AutoFilter
'Filter Specific Countries
rng.AutoFilter Field:=FilterField, Criteria1:=Array( _
"V600E", "KELRE745delinsK", "T790M", "G719S", "D816V", "G13D", "G12D", "Q61K", "H1047R", "L858R", "E545K"), Operator:=xlFilterValues
Else 'If InStr(1, ActiveSheet.Range("A2").Value, "HD300") > 0 Then
rng.AutoFilter
rng.AutoFilter Field:=FilterField, Criteria1:=Array( _
"L861Q", "KELRE745delinsK", "L858R", "T790M", "G719S"), Operator:=xlFilterValues
End If
'End If
'~~~> format top row.
Range("A1").Select 'format top row
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.Pattern = xlPatternLinearGradient
.Gradient.Degree = 90
.Gradient.ColorStops.clear
End With
With Selection.Interior.Gradient.ColorStops.Add(0)
.Color = 11298378
.TintAndShade = 0
End With
With Selection.Interior.Gradient.ColorStops.Add(1)
.Color = 5384228
.TintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Answer 1

Just this bit of code to add borders could speed things up.
LastRow2 = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
Range("A2:G" & LastRow2).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.colorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Can be replaced with this. Edit your code to remove the selects.
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("QC")
Dim rng As Range
LastRow2 = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
Set rng = sht.Range("A2:G" & LastRow2)
With rng.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With