VBAnewbie7
New Member
- Joined
- Aug 24, 2019
- Messages
- 7
Any tips on cleaning this up to make it run a bit quicker?
I've done all the tips i know, which is basically shutting off calculations, screen updating, etc. until the end.
There is a lot of selecting and formatting but every time i try to mess with it, it breaks it.
Thanks in advance!
I've done all the tips i know, which is basically shutting off calculations, screen updating, etc. until the end.
There is a lot of selecting and formatting but every time i try to mess with it, it breaks it.
Thanks in advance!
Code:
Sub DataSnapShot()
Application.Calculation = xlManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = True
' Creates a sheet for each item code with a snapshot of the data that corresponds to it.
Sheets("Sheet1").Select
Dim ArList As Object, Ar As Variant, Col As Long, Ws As Worksheet
Dim ColName As String, lRow As Long, Rg As Range
Set ArList = CreateObject("System.Collections.ArrayList")
Set Ws = ActiveSheet
Col = Application.InputBox("Please select the column of data you would like to create snapshots for.", Type:=8).Column
Application.ScreenUpdating = False
Ar = ActiveSheet.Range("A1").CurrentRegion
ColName = Ws.Cells(1, Col)
lRow = UBound(Ar)
For x = 2 To UBound(Ar)
If Not ArList.contains(Ar(x, Col)) Then ArList.Add Ar(x, Col)
Next
ReDim Ar(1 To ArList.Count): Ar = ArList.ToArray
For x = 0 To UBound(Ar)
On Error Resume Next
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Ar(x)
Set Rg = Ws.Cells(lRow + 2, Col).Resize(2)
Rg = Application.Transpose(Array(ColName, Ar(x)))
Ws.[A1].CurrentRegion.AdvancedFilter xlFilterCopy, Rg, Sheets(Ar(x)).[A1]
'Insert 10 Rows Above Row 1
Rows("1:10").Insert Shift:=xlDown, _
CopyOrigin:=xlFormatFromLeftOrAbove
' This inserts buttons and asigns a macro to them
ActiveSheet.Buttons.Add(759, 3.75, 109.5, 39).Select
Selection.OnAction = "ExcludeZeros"
Selection.Characters.Text = "Exclude EAS Zeros"
With Selection.Characters(Start:=1, Length:=13).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("P7").Select
ActiveSheet.Buttons.Add(762, 51, 107.25, 39.75).Select
Selection.OnAction = "ReincludeZeros"
Selection.Characters.Text = "Reinclude EAS Zeros"
With Selection.Characters(Start:=1, Length:=15).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("T6").Select
' This creates more buttons, assigns macros to those buttons, then formats and rearranges all buttons to be more asthetically pleasing/useful
ActiveSheet.Buttons.Add(578.25, 14.25, 90.75, 27.75).Select
Selection.OnAction = "ParentSelect"
Selection.Characters.Text = "Parent Only"
With Selection.Characters(Start:=1, Length:=11).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("M5").Select
ActiveSheet.Buttons.Add(581.25, 51, 87.75, 27.75).Select
Selection.OnAction = "ChildSelect"
Selection.Characters.Text = "Child Only"
With Selection.Characters(Start:=1, Length:=10).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("N8").Select
ActiveSheet.Buttons.Add(578.25, 86.25, 91.5, 26.25).Select
Selection.OnAction = "ResetPCfilter"
Selection.Characters.Text = "Reset Parent/Child"
With Selection.Characters(Start:=1, Length:=18).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("O8").Select
ActiveSheet.Shapes.Range(Array("Button 5")).Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Underline = xlUnderlineStyleNone
.ColorIndex = 3
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("K2:R9").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 480.75, 13.5, 72.75 _
, 25.5).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Filters:"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 8).ParagraphFormat. _
FirstLineIndent = 0
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 8).Font
.Bold = msoTrue
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 16
.Name = "+mn-lt"
.UnderlineStyle = msoUnderlineSingleLine
End With
Range("O4").Select
ActiveSheet.Shapes.Range(Array("Button 3")).Select
ActiveSheet.Shapes("Button 3").IncrementLeft -16.5
ActiveSheet.Shapes.Range(Array("Button 4")).Select
ActiveSheet.Shapes("Button 4").IncrementLeft -19.5
ActiveSheet.Shapes("Button 4").IncrementTop -6
ActiveSheet.Shapes("Button 4").ScaleWidth 1.0427350427, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes("Button 4").ScaleHeight 1.027027027, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes.Range(Array("Button 5")).Select
ActiveSheet.Shapes("Button 5").IncrementLeft -17.25
ActiveSheet.Shapes("Button 5").IncrementTop -8.25
ActiveSheet.Shapes("Button 5").ScaleWidth 1.0081967213, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes("Button 5").ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft
ActiveSheet.Shapes.Range(Array("Button 1")).Select
ActiveSheet.Shapes("Button 1").IncrementLeft -96
ActiveSheet.Shapes("Button 1").IncrementTop 11.25
ActiveSheet.Shapes.Range(Array("Button 2")).Select
ActiveSheet.Shapes("Button 2").IncrementLeft -99
ActiveSheet.Shapes("Button 2").IncrementTop 6.75
ActiveSheet.Shapes("Button 2").ScaleWidth 1.027972028, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes.Range(Array("Button 5")).Select
ActiveSheet.Shapes("Button 5").IncrementTop 2.25
ActiveSheet.Shapes.Range(Array("Button 4")).Select
ActiveSheet.Shapes("Button 4").IncrementLeft -0.75
ActiveSheet.Shapes("Button 4").IncrementTop 3.75
ActiveSheet.Shapes.Range(Array("Button 3")).Select
ActiveSheet.Shapes("Button 3").ScaleHeight 1.1081081081, msoFalse, _
msoScaleFromTopLeft
Range("S2").Select
' This creates a table with calculations based on the data
Range("D2").FormulaR1C1 = "Total RROs"
Range("E2").FormulaR1C1 = "Total EAS Hours"
Range("F2").FormulaR1C1 = "Average EAS Hours"
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Range("D2:F3").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
Columns("D:D").EntireColumn.AutoFit
Range("D3").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(3,R[9]C[-3]:R[2000]C[-3])"
Range("D4").Select
ActiveWindow.SmallScroll Down:=-21
Range("E3").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(109,R[9]C[12]:R[2000]C[12])"
Range("E4").Select
ActiveWindow.SmallScroll Down:=-21
Range("F3").Select
ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-2]"
Range("F3").Select
Selection.NumberFormat = "0.0"
Range("D2:F2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Range("E5").Select
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Range("D3:F3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("F3").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Range("F3").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Sheets("Sheet1").Select
Application.Calculation = xlAutomatic
Next
Rg.Delete
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub
Last edited by a moderator: