How to apply a macro function with three command buttons ? I tried with below code.. but returns the macro applied on different sheet.
cmd button1: browses the main raw data file.
cmd button2: vlookup data file for the main raw data file.
cmd button3: Run the macro below function on the main raw data file.
your ideas will be much helpful.. thanks in advance.
Option Explicit
Sub currentZOE3()
'declare variable to store path
Dim Get_Path As String
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show <> 0 Then
Get_Path = .SelectedItems(1)
End If
Worksheets("sheet1").Cells(3, 4).Value = Get_Path
End With
End Sub
Sub lastweekZOE3()
'declare variable to store path
Dim Get_Path As String
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show <> 0 Then
Get_Path = .SelectedItems(1)
End If
Worksheets("sheet1").Cells(5, 4).Value = Get_Path
End With
End Sub
Sub Macro4()
'
' Macro4 Macro
'
'
Dim updWb As Workbook
Dim DSheet As Worksheet
Set updWb = Workbooks.Open(Worksheets("sheet1").Cells(3, 4).Value)
Set DSheet = updWb.Sheets("Sheet1")
Cells.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
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Rows("1:1").Select
Selection.Font.Bold = True
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
Columns("N:N").Select
Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
Columns("Q:S").Select
Selection.Insert Shift:=xlToRight
Range("Q1") = "Concantenate"
Range("R1") = "Delivery Plan"
Range("S1") = "Last Week Comments"
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=RC[-16]&RC[-9]&RC[-7]"
Range("S2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],'[Last Week.xlsx]Sheet1'!C1:C2,2,0)"
Range("R2").Select
ActiveCell.FormulaR1C1 = _
"=IFS(RC22=""YBWR"",""What"",ISNUMBER(RC25),""Fully Delivered"",RC19=""Billable Only"",""BILLABLE ONLY"",AND(ISBLANK(RC25),NOT(ISBLANK(RC27))),""Under shipment"",AND(ISBLANK(RC25),ISBLANK(RC27),ISNUMBER(RC14)),""Under packing"",AND(ISBLANK(RC25),ISBLANK(RC27),ISBLANK(RC14)),TEXT(WEEKNUM(RC23),""W00""))"
Range("P3").Select
Selection.End(xlDown).Select
Range("Q8833:S8833").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Cells.Select
Range("Q8833").Activate
Selection.Columns.AutoFit
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""What"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 12173758
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""Fully Delivered"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 5691552
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""under shipment"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 3774674
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
With Cells
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=($R1=""under packing"")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 15793920
.TintAndShade = 0
End With
StopIfTrue = False
End With
End With
Sheets(Array("Sheet2", "Sheet3")).Select
Sheets("Sheet3").Activate
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Range("A1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("A1:A8837"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$BE$8837").AutoFilter Field:=1
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long
Dim pvtfield As PivotField
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("Sheet1")
'Define Data Range
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)
'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="PivotTable")
'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
(TableDestination:=PSheet.Cells(1, 1), TableName:="PivotTable")
'Insert Row Fields
With ActiveSheet.PivotTables("PivotTable").PivotFields("Sold to name")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable").PivotFields("Sales Document")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTable").PivotFields("Customer purchase order number")
.Orientation = xlRowField
.Position = 3
End With
'Insert Column Fields
With ActiveSheet.PivotTables("PivotTable").PivotFields("Delivery Plan")
.Orientation = xlColumnField
.Position = 1
End With
'Insert Data Field
With ActiveSheet.PivotTables("PivotTable").PivotFields("SO Net value")
.Orientation = xlDataField
.Position = 1
.Function = xlSum
.NumberFormat = "#,##0"
.Name = " Sum SO Net value "
End With
'classic and expand/collapse button removal
Range("C7").Select
With ActiveSheet.PivotTables("PivotTable")
.InGridDropZones = True
.RowAxisLayout xlTabularRow
End With
Range("B4").Select
ActiveSheet.PivotTables("PivotTable").ShowDrillIndicators = False
'Format Pivot
TableActiveSheet.PivotTables("PivotTable").ShowTableStyleRowStripes = TrueActiveSheet.PivotTables("PivotTable").TableStyle2 = "PivotStyleMedium9"
End Sub
Once you have the path of the file using the FileDialog method.
You can use the below function to open that excel and update the contents of it's worksheets.
Dim updWb As Workbook, wSheet As Worksheet
Set updWb = Workbooks.Open("<path of the workbook to be updated>")
Set wSheet = updWb.Sheets("<sheet-name> or <sheet-index>")
Related
I've created a macro (using lots of online help) to take data from one sheet, create another sheet, format the data and set up the printer.
Everything works as it should but the macro seems to take a long time to run.
Would someone be able to look at my code and see if I've done something that I shouldn't?
Thanks
Sub Preactor_Sort()
Application.ScreenUpdating = False
'**Copy "Full List" Data into New Sheet**
Sheets("FULL LIST").Select
Range("A8:R8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add(Before:=Sheets("MASTER")).Name = "Sorted Full"
Range("A1").Select
ActiveSheet.Paste
ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
Cells.FormatConditions.Delete
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 9
.Bold = False
.Color = vbBlack
End With
With Selection
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.WrapText = True
.Interior.ColorIndex = 0
.RowHeight = 23
End With
Cells.EntireColumn.AutoFit
'***************************************************
'**Deleting Unwanted Columns**
Columns("E:E").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("A:C").Select
Range("A1").Activate
Selection.Delete Shift:=xlToLeft
'***************************************************
'**Rearranging Columns**
Columns("G:H").Select
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Columns("K:L").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
'****************************************************
'**Sorting Day/Date**
Columns("C:C").Select
Selection.NumberFormat = "dd/mm/yy hh:mm"
Columns("C:C").EntireColumn.AutoFit
Columns("C:C").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("C:C").Select
Selection.NumberFormat = "General"
'**Find Last Row**
LR = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
'**Insert Formula**
Range("C2").Formula = "=TEXT(D2,""ddd"")"
'**Drag Formula down to last row**
Range("C2").AutoFill Range("C2:C" & LR)
Columns("C:C").EntireColumn.AutoFit
'*****************************************************
'**Sorting**
With ActiveSheet.Sort
.SortFields.Add2 Key:=Range("C1"), Order:=xlAscending, CustomOrder:="Mon,Tue,Wed,Thu,Fri,Sat,Sun", DataOption:=xlSortNormal
.SortFields.Add2 Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Make,Discharge,Packing,Wrapping", DataOption:=xlSortNormal
.SetRange Range("A:P")
.Header = xlYes
.Apply
End With
'******************************************************
'**Formatting**
Range("C:C,E:E").Select
With Selection
.Font.Bold = True
End With
Columns("B:B").Select
Selection.ColumnWidth = 10
Columns("F:G").Select
Selection.ColumnWidth = 25
Columns("A:A").Select
Selection.ColumnWidth = 8
Columns("I:J").Select
Selection.ColumnWidth = 5
Columns("L:N").Select
Selection.ColumnWidth = 15
Columns("O:O").Select
Selection.ColumnWidth = 80
Columns("H:H").Select
Selection.ColumnWidth = 40
Columns("K:K").Select
Selection.ColumnWidth = 6
'**Conditional Formatting**
'** Alternating Rows
Dim lastRow As Long
lastRow = Range("A1:P1").End(xlDown).Row
For Each cell In Range("A1:P" & lastRow)
If cell.Row Mod 2 = 1 Then
cell.Interior.ColorIndex = 34 'Light Blue
End If
Next cell
'**Highlighting Operations
Dim cell1 As Range
For Each cell1 In Range("B:B")
If cell1.Value = "Make" Then
cell1.Interior.ColorIndex = 35 'Light Green
ElseIf cell1.Value = "Discharge" Then
cell1.Interior.ColorIndex = 36 'Light Yellow
ElseIf cell1.Value = "Packing" Then
cell1.Interior.ColorIndex = 19 'Light Cream
ElseIf cell1.Value = "Wrapping" Then
cell1.Interior.ColorIndex = 6 'Yellow
ElseIf cell1.Value = "Boxing" Then
cell1.Interior.ColorIndex = 44 'Light Orange
ElseIf cell1.Value = "Oil Phase" Then
cell1.Interior.ColorIndex = 38 'Pink
End If
Next
'**Highlighting Day
Dim cell2 As Range
For Each cell2 In Range("C:C")
If cell2.Value = "Mon" Then
cell2.Interior.ColorIndex = 7 'Pink
ElseIf cell2.Value = "Tue" Then
cell2.Interior.ColorIndex = 4 'Green
ElseIf cell2.Value = "Wed" Then
cell2.Interior.ColorIndex = 6 'Yellow
ElseIf cell2.Value = "Thu" Then
cell2.Interior.ColorIndex = 45 'Orange
ElseIf cell2.Value = "Fri" Then
cell2.Interior.ColorIndex = 33 'Blue
End If
Next
'** Top Bar Colour
Range("A1:P1").Select
With Selection
.Interior.ColorIndex = 15
.Font.Bold = True
End With
'*********************************************************
'** Printer Setup
Application.PrintCommunication = True
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.12)
.RightMargin = Application.InchesToPoints(0.12)
.TopMargin = Application.InchesToPoints(0.16)
.BottomMargin = Application.InchesToPoints(0.16)
.HeaderMargin = Application.InchesToPoints(0.12)
.FooterMargin = Application.InchesToPoints(0.12)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
' Application.PrintCommunication = False
End Sub
Trying adding in this, it speeds up by turning off screen updating, events, animations etc, this should speed it up a bit!
At the start of your code add in this sub
Call TurnOffCode
At the end of your code add in this sub
Call TurnOnCode
This is what they should both look like
Sub TurnOffCode() 'Used to turn off settings to make workbook run faster
Application.Calculation = xlCalculationManual 'Set calculations to manual
Application.ScreenUpdating = False 'Turns off screen updating
Application.EnableEvents = False 'Turns off events
Application.EnableAnimations = False 'Turns off animations
Application.DisplayStatusBar = False 'Turns off display status bar
Application.PrintCommunication = False 'Turns off print communications
End Sub
Sub TurnOnCode() 'Used to turn settings back on to normal
Application.Calculation = xlCalculationAutomatic 'Set calculations to automatic
Application.ScreenUpdating = True 'Turns on screen updating
Application.EnableEvents = True 'Turns on events
Application.EnableAnimations = True 'Turns on animations
Application.DisplayStatusBar = True 'Turns on display status bar
Application.PrintCommunication = True 'Turns on print communications
End Sub
However, you should also avoid using selects as well, look at the comment section for a page displaying that information
Thanks for looking at this for me.
I tried the solution that EuanM28 offered and this did marginally increase the speed - from 38sec to around 34sec.
I made a couple of tweaks to my code from
Dim cell1 As Range
For Each cell1 In Range("B:B")
to
Dim cell1 As Range
For Each cell1 In Range("B2:B" & LR) '*LR = last row variable defined earlier in the code
and
Dim cell2 As Range
For Each cell2 In Range("C:C")
to
Dim cell2 As Range
For Each cell2 In Range("C2:C" & LR)
This made a huge difference (34sec to 6sec) I'm guessing because it's no longer cycling through all the rows on the sheet and just the populated ones.
I will have to look into removing .Selects as suggested (didn't realise it causes so many issues!)
Thanks
You have a lot of select statements in your code only to subsequently do something with the selection you can avoid that.
A section like the below
Application.ScreenUpdating = False
'**Copy "Full List" Data into New Sheet**
Sheets("FULL LIST").Select
Range("A8:R8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add(Before:=Sheets("MASTER")).Name = "Sorted Full"
Range("A1").Select
ActiveSheet.Paste
ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
Cells.FormatConditions.Delete
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 9
.Bold = False
.Color = vbBlack
End With
With Selection
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.WrapText = True
.Interior.ColorIndex = 0
.RowHeight = 23
End With
Cells.EntireColumn.AutoFit
can be rewritten as:
Dim slc As Range
Dim rng As Range
'Application.ScreenUpdating = False <= be careful with setting update to false as it will not restore if your program encounters an error!
'**Copy "Full List" Data into New Sheet**
Set rng = Sheets(1).Range("A8:R8")
Set slc = Range(rng, rng.End(xlDown))
slc.Copy
Sheets.Add(Before:=Sheets(1)).Name = "Sorted Full"
Sheets("Sorted Full").Paste
ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
Cells.FormatConditions.Delete
With Cells.Font
.Name = "Calibri"
.Size = 9
.Bold = False
.Color = vbBlack
End With
With Cells
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.WrapText = True
.Interior.ColorIndex = 0
.RowHeight = 23
End With
Cells.EntireColumn.AutoFit
This will prevent Excel from making the select statement which is causing the slow execution and flickering of the screen.
If you apply that throughout your code you will have a much cleaner execution, without the need to turn off screen updating.
So, if you clean up your code a bit it can look like below:
Mind you, even this has plenty of room for improvement but at least it get's rid of most of the select statements.
This can still be combined with the solution proposed by #EuanM28
However, there are some drawbacks with switching of calculation and screenupdates that may require appropriate ErrorHandling in case your macro encounters an error.
So, combining them would look like the below:
Sub Preactor_Sort()
On Error GoTo ErrorHandler '<= called in case of an Error
Call ToggleCode(False)
Dim slc As Range
Dim rng As Range
'Application.ScreenUpdating = True
'**Copy "Full List" Data into New Sheet**
Set rng = Sheets(1).Range("A8:R8")
Set slc = Range(rng, rng.End(xlDown))
slc.Copy
Sheets.Add(Before:=Sheets(1)).Name = "Sorted Full"
Sheets("Sorted Full").Paste
ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
With Cells
.FormatConditions.Delete
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.WrapText = True
.Interior.ColorIndex = 0
.RowHeight = 23
With .Font
.Name = "Calibri"
.Size = 9
.Bold = False
.Color = vbBlack
End With
.EntireColumn.AutoFit
End With
'***************************************************
'**Deleting Unwanted Columns**
columns("E:E").Cut
columns("C:C").Insert Shift:=xlToRight
columns("A:C").Delete Shift:=xlToLeft
'***************************************************
'**Rearranging Columns**
columns("G:H").Cut
columns("B:B").Insert Shift:=xlToRight
columns("K:L").Cut
columns("E:E").Insert Shift:=xlToRight
'****************************************************
'**Sorting Day/Date**
columns("C:C").NumberFormat = "dd/mm/yy hh:mm"
columns("C:C").EntireColumn.AutoFit
columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
columns("C:C").NumberFormat = "General"
'**Find Last Row**
LR = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).row
'**Insert Formula**
Range("C2").Formula = "=TEXT(D2,""ddd"")"
'**Drag Formula down to last row**
Range("C2").AutoFill Range("C2:C" & LR)
columns("C:C").EntireColumn.AutoFit
'*****************************************************
'**Sorting**
With ActiveSheet.Sort
.SortFields.Add2 Key:=Range("C1"), Order:=xlAscending, CustomOrder:="Mon,Tue,Wed,Thu,Fri,Sat,Sun", DataOption:=xlSortNormal
.SortFields.Add2 Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Make,Discharge,Packing,Wrapping", DataOption:=xlSortNormal
.SetRange Range("A:P")
.Header = xlYes
.Apply
End With
'******************************************************
'**Formatting**
Range("C:C,E:E").Font.Bold = True
columns("B:B").ColumnWidth = 10
columns("F:G").ColumnWidth = 25
columns("A:A").ColumnWidth = 8
columns("I:J").ColumnWidth = 5
columns("L:N").ColumnWidth = 15
columns("O:O").ColumnWidth = 80
columns("H:H").ColumnWidth = 40
columns("K:K").ColumnWidth = 6
'**Conditional Formatting**
'** Alternating Rows
Dim lastRow As Long
lastRow = Range("A1:P1").End(xlDown).row
For Each cell In Range("A1:P" & lastRow)
If cell.row Mod 2 = 1 Then
cell.Interior.ColorIndex = 34 'Light Blue
End If
Next cell
'**Highlighting Operations
Dim cell1 As Range
For Each cell1 In Range("B:B")
If cell1.value = "Make" Then
cell1.Interior.ColorIndex = 35 'Light Green
ElseIf cell1.value = "Discharge" Then
cell1.Interior.ColorIndex = 36 'Light Yellow
ElseIf cell1.value = "Packing" Then
cell1.Interior.ColorIndex = 19 'Light Cream
ElseIf cell1.value = "Wrapping" Then
cell1.Interior.ColorIndex = 6 'Yellow
ElseIf cell1.value = "Boxing" Then
cell1.Interior.ColorIndex = 44 'Light Orange
ElseIf cell1.value = "Oil Phase" Then
cell1.Interior.ColorIndex = 38 'Pink
End If
Next
'**Highlighting Day
Dim cell2 As Range
For Each cell2 In Range("C:C")
If cell2.value = "Mon" Then
cell2.Interior.ColorIndex = 7 'Pink
ElseIf cell2.value = "Tue" Then
cell2.Interior.ColorIndex = 4 'Green
ElseIf cell2.value = "Wed" Then
cell2.Interior.ColorIndex = 6 'Yellow
ElseIf cell2.value = "Thu" Then
cell2.Interior.ColorIndex = 45 'Orange
ElseIf cell2.value = "Fri" Then
cell2.Interior.ColorIndex = 33 'Blue
End If
Next
'** Top Bar Colour
'Range("A1:P1").Select
With Range("A1:P1")
.Interior.ColorIndex = 15
.Font.Bold = True
End With
'*********************************************************
'** Printer Setup
'Application.PrintCommunication = True
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.12)
.RightMargin = Application.InchesToPoints(0.12)
.TopMargin = Application.InchesToPoints(0.16)
.BottomMargin = Application.InchesToPoints(0.16)
.HeaderMargin = Application.InchesToPoints(0.12)
.FooterMargin = Application.InchesToPoints(0.12)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
' Application.PrintCommunication = False
Call ToggleCode(True)
Exit Sub
ErrorHandler:
Call ToggleCode(True) '<= this ensures your application get's reset in case of an Error
End Sub
Sub ToggleCode(Optional switch As Boolean = True) 'Used to turn on/off settings to make workbook run faster
If (switch) Then
Application.Calculation = xlCalculationAutomatic 'Set calculations to automatic
Else
Application.Calculation = xlCalculationManual 'Set calculations to manual
End If
Application.ScreenUpdating = switch 'Turns on/off screen updating
Application.EnableEvents = switch 'Turns on/off events
Application.EnableAnimations = switch 'Turns on/off animations
Application.DisplayStatusBar = switch 'Turns on/off display status bar
Application.PrintCommunication = switch 'Turns on/off print communications
End Sub
My excel is being corrupted.
When I open excel the following message appears:
"We found a problem with some content in "". Do you want us to try to recover as much as we can? If you trust the source of this workbook, click Yes"
And when I click "yes" opens excel with the "input4" tab misconfigured
I think it may be something related to the macros I added below.
I can't figure out where the problem is, can someone help me please?
Sub gera_quadro_inp4()
Dim n As Integer
Dim u As Integer
Dim LastR As Integer
Dim Cart As String
With Workbooks("TAB AUTO.xlsm").Sheets("input4").Range("B7:B100").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="mar/2008,jun/2008,set/2008,dez/2008,mar/2009,jun/2009,set/2009,dez/2009,mar/2010,jun/2010,set/2010,dez/2010,mar/2011,jun/2011,set/2011,dez/2011,mar/2012,jun/2012,set/2012,dez/2012,mar/2013,jun/2013,set/2013,dez/2013,mar/2014,jun/2014,set/2014,dez/2014,mar/2015,jun/2015,set/2015,dez/2015,mar/2016,jun/2016,set/2016,dez/2016,mar/2017,jun/2017,set/2017,dez/2017,mar/2018,jun/2018,set/2018,dez/2018,mar/2019,jun/2019,set/2019,dez/2019,mar/2020,jun/2020,set/2020,dez/2020,mar/2021,jun/2021,set/2021,dez/2021,mar/2022,jun/2022,set/2022,dez/2022,mar/2023,jun/2023,set/2023,dez/2023,mar/2024,jun/2024,set/2024," & _
"dez/2024,mar/2025,jun/2025,set/2025,dez/2025,mar/2026,jun/2026,set/2026,dez/2026,mar/2027,jun/2027,set/2027,dez/2027,mar/2028,jun/2028,set/2028,dez/2028,mar/2029,jun/2029,set/2029,dez/2029,mar/2030,jun/2030,set/2030,dez/2030,mar/2031,jun/2031,set/2031,dez/2031,mar/2032,jun/2032,set/2032,dez/2032,mar/2033,jun/2033,set/2033,dez/2033,mar/2034,jun/2034,set/2034,dez/2034,mar/2035,jun/2035,set/2035,dez/2035,mar/2036,jun/2036,set/2036,dez/2036,mar/2037,jun/2037,set/2037,dez/2037,mar/2038,jun/2038,set/2038,dez/2038,mar/2039,jun/2039,set/2039,dez/2039,mar/2040,jun/2040,set/2040,dez/2040"
End With
LastR = Workbooks("TAB AUTO.xlsm").Sheets("input1").Range("C8").End(xlDown).row
'Armazena carteiras em Cart
For Each Value In Workbooks("TAB AUTO.xlsm").Sheets("input1").Range("B8:B" & LastR)
Cart = Cart & "," & Value
Next Value
'Cria lista de opção de carteiras
With Workbooks("TAB AUTO.xlsm").Sheets("input4").Range("C7:C100").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Cart
End With
'Cria variáveis do quadro
cen = Workbooks("TAB AUTO.xlsm").Sheets("input3").Range("F6").Value
Workbooks("TAB AUTO.xlsm").Sheets("input4").Range(Workbooks("TAB AUTO.xlsm").Sheets("input4").Cells(6, 2), Workbooks("TAB AUTO.xlsm").Sheets("input4").Cells(6, 100)).Value = ""
Workbooks("TAB AUTO.xlsm").Sheets("input4").Range("B6").Value = "PERIODO_TRI_AJUSTE"
Workbooks("TAB AUTO.xlsm").Sheets("input4").Range("C6").Value = "CARTEIRA"
Workbooks("TAB AUTO.xlsm").Sheets("input4").Range("D6").Value = "VALOR_ANCL_ANT"
For u = 1 To cen
Workbooks("TAB AUTO.xlsm").Sheets("input4").Cells(6, 4 + u).Value = "OVERRIDE_TRI_C" & u
Workbooks("TAB AUTO.xlsm").Sheets("input4").Cells(6, 4 + cen + u).Value = "OVERRIDE_ANO_C" & u
Next u
Workbooks("TAB AUTO.xlsm").Sheets("input4").Range("B6").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
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
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Selection.Font.Bold = True
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub
'Gera input4
Sub gera_input4()
Dim nework As Workbook
Workbooks("TAB AUTO.xlsm").Sheets("input4").Range("B6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Set nework = Workbooks.Add
nework.Sheets(1).Range("A1").PasteSpecial xlPasteValues
nework.Sheets(1).Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "mmm-yy"
Cells.Select
Cells.EntireColumn.AutoFit
nework.Sheets(1).Range("A1").Select
End Sub
I have a macro which takes data from one workbook, filters the fairly large page down to the data i require only, then copies values to a dummy sheet in my main workbook where non required rows are removed and columns are sorted into an order more suitable for my application.
my problem is it takes an age to complete and quite often crashes.
I am still new to VBA and have tried my best to slicken the code but am not getting anywhere. I have used F8 to define the areas which slow it up and they are the filtering, copy/paste and cut/insert. If anyone can help it would be greatly appreciated.
Thanks in advance
M
`Sub NEW_OPS_AWAY_REPORT()
MsgBox ("BOTTLENECKS AND OPS AWAY SPREADSHEET & GEARSHOP WORK TO LIST FROM REPORT CENTRE MUST BE OPEN FOR THIS REPORT TO FUNCTION CORRECTLY")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Windows("DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm").Activate
Sheets("WIP by Op").Visible = True
Sheets("WIP by Op").Range("$A$1:$Q$47290").AutoFilter Field:=1, Criteria1:="TS1H124*", Operator:=xlFilterValues
Windows("PRESS QUENCH FIRST OFF DATABASE.xlsm").Activate
Sheets("REPORT DATA TRANSFER").Visible = True
Sheets("REPORT DATA TRANSFER").Select
Cells.Select
Selection.ClearContents
Windows("DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm").Activate
Sheets("WIP by Op").Select
Cells.Select
Selection.Copy
Windows("PRESS QUENCH FIRST OFF DATABASE.xlsm").Activate
ActiveSheet.Paste
Range("F:F,G:G,H:H,M:M,P:P,Q:Q").Select
Range("Q1").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("A:K").Select
Columns("A:K").EntireColumn.AutoFit
Columns("J:J").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("I:I").Select
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Columns("J:J").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Cut
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Columns("J:J").Select
Selection.Cut
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Application.Calculation = xlCalculationAutomatic
Range("A1:K1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort.SortFields. _
Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Ops Away Report").Select
Columns("A:K").Select
Selection.ClearContents
Sheets("REPORT DATA TRANSFER").Select
Columns("A:K").Select
Selection.Copy
Sheets("Ops Away Report").Select
Range("A1").Select
ActiveSheet.Paste
Range("A:A,E:E,F:F,I:I,J:J").Select
Range("J1").Activate
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).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
Range("A1:L1").Select
Selection.AutoFilter
Columns("B:B").Select
Sheets("REPORT DATA TRANSFER").Visible = False
Dim lastRow As Long
lastRow = Range("A2").End(xlDown).Row
For Each Cell In Range("A2:Q" & lastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.ColorIndex = 34 ''color to preference
Else
Cell.Interior.ColorIndex = xlNone ''color to preference or remove
End If
Next Cell
Columns("D:D").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 7.43
Range("A1:O1").AutoFilter
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub`
Looking through your code there's a lot of extra code in there.
For instance, adding a border around each cell can be done with Selection.Borders.LineStyle = xlContinuous
This code starts with the two workbooks closed. Update the Const variables with the correct file paths.
You'll probably need to disable events still, depending on what code's in the other workbooks.
Public Sub New_Ops_Away_Report()
Const BottleNecks_Path As String = "C:\Somefolder\DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm"
Const OpsAway_Path As String = "C:\Somefolder\PRESS QUENCH FIRST OFF DATABASE.xlsm"
Dim wrkBk_BottleNeck As Workbook
Dim wrkbk_OpsAway As Workbook
Dim rWIP_LastCell As Range
Dim rReport_LastCell As Range
Set wrkBk_BottleNeck = Workbooks.Open(Filename:=BottleNecks_Path)
Set wrkbk_OpsAway = Workbooks.Open(Filename:=OpsAway_Path)
'Clear the contents of the named sheet.
wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Cells.ClearContents
With wrkBk_BottleNeck
'Find the last populated cell on the worksheet.
Set rWIP_LastCell = LastCell(.Worksheets("WIP by OP"))
With .Worksheets("WIP by OP")
With .Range(.Cells(1, 1), rWIP_LastCell)
'Add a filter from A1 to the last populated cell.
.AutoFilter Field:=1, Criteria1:="TS1H124*", Operator:=xlFilterValues
.Copy Destination:=wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Range("A1")
End With
End With
End With
With wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER")
''''''''''''''''''''''''
'This bit is confusing in your code.
'I think it's trying to do as below, but I've commented out the last line
'as it appears to clear the data you just copied over.
.Range("F:F,G:G,H:H,M:M,P:P,Q:Q").Delete Shift:=xlToLeft
.Columns("A:K").EntireColumn.AutoFit
'.Columns("A:J").EntireColumn.ClearContents
''''''''''''''''''''''''
'Find last populated cell on the worksheet.
Set rReport_LastCell = LastCell(wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER"))
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1").Resize(rReport_LastCell.Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Range("A1").Resize(rReport_LastCell.Row, rReport_LastCell.Column)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Range("A1").Resize(rReport_LastCell.Row, rReport_LastCell.Column).Borders.LineStyle = xlContinuous
End With
End Sub
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
I am trying to automate some pieces of my reports for work. I want to have a macro that will take all the raw data in a worksheet and create/design the same pivot table every time.
I have been able to create a normal table in this way by avoiding absolutes such as Ctrl+shft+ down arrow to select all the data but with Pivot Tables I run into this error:
Just to be as specific as possible. With my macro use I have been unable to:
Create a Pivot Table
Rename a worksheet
Sort the values from largest to smallest.
In all my macros, these 3 things will cause it to crash in a run time error.
Is there anyway to modify the code to allow these three things to work?
Here is my Macro code. The three things I want to accomplish are in this pivot table macro. Sorry for any miss clicks in the creation of the macro. Thanks for any help you guys might provide.
Sub Create_pivotTable()
'
' Create_pivotTable Macro
'
'
Cells.Select
Sheets.Add
ActiveWorkbook.Worksheets("Pivot Table").PivotTables("PivotTable6").PivotCache. _
createPivotTable TableDestination:="Sheet1!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion14
Sheets("Sheet1").Select
Cells(3, 1).Select
Sheets("Sheet1").Select
Sheets("Sheet1").Move Before:=Sheets(5)
Sheets("Sheet1").Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Debit Party Name")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Credit Party Name")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Original Amount"), "Count of Original Amount", _
xlCount
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Transaction Date"), "Count of Transaction Date", _
xlCount
Sheets("Sheet1").Name = "Piv Tab"
Rows("1:2").Select
Range("A2").Activate
Selection.Delete Shift:=xlUp
Range("A1").Select
ActiveSheet.PivotTables("PivotTable1").CompactLayoutRowHeader = _
"ORIGINATORS | BENEFICIARY'S"
Range("B1").Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
"Count of Original Amount")
.Caption = "Amount"
.Function = xlSum
End With
Range("C1").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Count of Transaction Date") _
.Caption = "Count"
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Amount")
.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(#_)"
End With
Range("B2").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Debit Party Name"). _
AutoSort xlDescending, "Amount", ActiveSheet.PivotTables("PivotTable1"). _
PivotColumnAxis.PivotLines(1), 1
Range("B4").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Credit Party Name"). _
AutoSort xlDescending, "Amount", ActiveSheet.PivotTables("PivotTable1"). _
PivotColumnAxis.PivotLines(1), 1
Columns("D:D").ColumnWidth = 45.86
Range("D1").Select
ActiveCell.FormulaR1C1 = "Analysis"
Range("B1").Select
ActiveSheet.PivotTables("PivotTable1").TableStyle2 = "PivotStyleMedium3"
Range("A1").Select
Selection.Copy
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range(Selection, Selection.End(xlDown)).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("C:C").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("D7").Select
End Sub
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
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