我有一系列格式化单个工作表的宏，如果找到匹配项，则从硬编码数组导入值。代码评论很好。宏按其列出的顺序调用。我想了解如何加速代码或隐藏工作表的视图，以便用户在宏运行时看不到屏幕上的任何操作。非常感谢你。
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
答案 0 :(得分：0)
添加边框的这段代码可以加快速度。
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
可以替换为此。编辑代码以删除选择。
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