I have a map chart in excel, I'm creating a series of points using zipcodes, but once I'm done with the map I want to remove the borders around each zipcode. I have around 25000 points. I have accomplished this with the following code, but it takes about 2 hours to do this which is not efficient and also every time you try to open the file, it freezes for hours or it just crashes.
Thank you for you help.
Dim aChart As Chart
Dim serPoints As Long
Dim oSer As Series
Dim curPoint As Long
Set aChart = ActiveChart
Set oSer = aChart.SeriesCollection(1)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
serPoints = oSer.Points.Count
'changes the border of the line to 0
For curPoint = 1 To serPoints
oSer.Points(curPoint).Format.Line.Weight = 0
Next curPoint
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Here is the map before running the code
and here is the map after I run the code
Related
This is a code that should copy from one open workbook (WorkbookA) to the other open one (WorkbookB):
Option Explicit
Dim shRange1 As String
Dim shRange2 As String
Dim shRange3 As String
Dim wrk As Workbook
Dim inx As Integer
Public Sub cPasteToWorkbookB()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
For inx = 2 To 6
chooseInx
ThisWorkbook.Worksheets(inx).Range(shRange1).Copy
findOpenWorkbookB
ActiveWorkbook.Worksheets(inx).Range(shRange1).PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Worksheets(inx).Range(shRange2).Copy
findOpenWorkbookB
pasteShRange3
Next inx
Set wrk = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
End Sub
It has the following function for the cases, which are ranges in different worksheets:
Function chooseInx()
Select Case inx
Case 2:
shRange1 = "C6:S17"
shRange2 = "K24:L27"
shRange3 = "C24"
Case 3:
shRange1 = "C6:W14"
shRange2 = "K21:L23"
shRange3 = "C21"
Case 4:
shRange1 = "C6:S14"
shRange2 = "K21:L23"
shRange3 = "C21"
Case 5:
shRange1 = "C6:S14"
shRange2 = "K21:L23"
shRange3 = "C21"
Case 6:
shRange1 = "C6:U14"
shRange2 = "K21:L23"
shRange3 = "C21"
End Select
End Function
The code does it's job, but for this part:
Case 5:
shRange1 = "C6:S14"
the macro seem to change any values to 0 only in range "P6:P14" (it's not a typo) and then pastes the 0s to WorkbookB. This does not happen when I go through the macro with F8 - then I have the values as they were initially in both workbooks. And for Case 4 it works flawlessly, despite the ranges are exactly the same.
Here is the function for browsing all the open workbooks in search for WorkbookB:
Function findOpenWorkbookB()
For Each wrk In Workbooks
If InStr(wrk.Name, "WorkbookB") > 0 Then
wrk.Worksheets(inx).Activate
Exit For
End If
Next
End Function
Why such result? Why it overwrites the a part that was supposed to be copied only? I struggle to understand what is happening in the process, so I might not be as communicative with this post as I want to be. Any remarks are welcomed, I will adjust the question accordingly.
I tried to slow the macro a bit on different steps (copying, pasting and in the findOpenWorkbookB function), but to no avail.
For your reference below is the shRange1, from Case 5 with affected column P, with sensitive data hidden:
In greyed cells to the right are formulas, the ones from colums Q and R simply sum some cells on the same row from the left, the right extreme one is visible on the screen. None of the formulas refer to column P, the problematic one.
You most likely have formulas that evaluate to 0 or "" in range P6:P14. Either delete the formulas or copy the formatting by changing Paste:=xlPasteValues to Paste:=xlPasteValuesAndNumberFormats.
Ok so I've googled this and checked on here, but there is nothing similar to what I need looking at and i'm not familiar with VBA, only Python.
In python I would select the data and put it into a list, then do my stuff, then retrieve the data from the list and apply it. What I'm asking is whether there is a way to simplify the below code using arrays; if there is what would be the best way to do that. This code has 5 of these for loops, which I think is where we are losing the efficiency. Currently the macro will take 10 minutes to run once. I have a feeling that is because the for loops here refresh the page for each cell selection? i might be wrong with that. I'm happy to post more code and even the spreadsheet if required. Rally appreciate anyone taking the time to have a look at this!
Set ar = Selection
For Each ar In ar.Rows
newHeight = ar.RowHeight + 12.5
ar.VerticalAlignment = xlTop
ar.RowHeight = newHeight
Next ar
For Each Row1 In Sheets("ReportSummary").Range("4:26").Rows
If Row1.Cells(1, 2).Value = "" Then Row1.RowHeight = 0
Next
Sheets("ReportSummary").Select
Sheets("ReportSummary").Range("F4:F26").WrapText = True
Sheets("ReportSummary").Range("F4:F26").EntireRow.AutoFit
Sheets("ReportSummary").Range("F4:F26").Select`
This is one way to do it:
Sub test()
'turn off unnecessary stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo whoops 'if there's an error make sure we turn it all back on again
Dim ar As Range
Dim x As Long
Set ar = Selection
For x = ar.Row To ar.Row + ar.Rows.Count - 1
With ar.Rows(x)
.RowHeight = .RowHeight + 12.5
.VerticalAlignment = xlTop
End With
Next x
With Sheets("ReportSummary")
For x = 4 To 26
If .Cells(x, 2) = "" Then .Rows(x).RowHeight = 0
Next x
With .Range("F4:F26")
.WrapText = True
.EntireRow.AutoFit
End With
End With
whoops:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
My team and I have an excel file where I use columns A to L. We use this file to send out different budgets and therefore have multiple versions of the file. What happens is that people start to adjust the column widths and afterwards the print area no longer fits.
We want to ensure a standardized layout version at all times.
I have set up a VBA that ensures that the pre-selected column widths are implemented upon opening the file. If somebody changes the width, this will automatically be adjusted when somebody else opens the file again.
The code I have works fine however, one problem is that it takes to long to run 2min30sec. Any suggestions on how to speed it up?
Sub Workbook_Open()
'-----START TIMER-----
Dim StartTime As Double
Dim TimeTaken As String
Dim ws As Worksheet
StartTime = Timer
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
On Error Resume Next
'For Each ws In ActiveWorkbook.Worksheets ' Start of the VBA loop
For Each ws In Worksheets ' Start of the VBA loop
With ws
ws.Activate 'this part ensures each seperate tab is activated and the below code is run through
Columns("A").ColumnWidth = 0.94 'this line determines the column width
Columns("B").ColumnWidth = 6.56 'this line determines the column width
Columns("C").ColumnWidth = 13.56
Columns("D").ColumnWidth = 13.56
Columns("E").ColumnWidth = 13.56
Columns("F").ColxumnWidth = 10.11
Columns("G").ColumnWidth = 6.11
Columns("H").ColumnWidth = 10.11
Columns("I").ColumnWidth = 10.11
Columns("J").ColumnWidth = 13.56
Columns("K").ColumnWidth = 6.56
Columns("L").ColumnWidth = 6.56
Wsh.Range("A1").Select 'this part ensure each worksheet view start position is A1
ActiveWindow.View = xlPageBreakPreview 'Set Activesheet to Page Break Preview Mode
ActiveWindow.Zoom = 114 'this line sets the permanent zoom % for all tabs
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
End With
Next ws
Application.Goto ThisWorkbook.Sheets("resume").Range("A1"), True 'starting position upon opening the file
'Worksheets(1).Activate 'this line make sure view is at first tab
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
'------ END TIMER------
TimeTaken = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Running time was " & TimeTaken & " (hours, minutes, seconds)"
End Sub
Application.ScreenUpdating = False
Dim r As Range
Dim a As Long
Set op = Worksheets("ZVCTOSTATUS")
Set CP = op.Columns("J")
Set CTO = op.Range("J1")
Set OD = op.Columns("G")
Set ZV = op.Columns("H")
op.Activate
fa = op.Range("J" & Rows.Count).End(xlUp).Row
Set r = op.Range("J2:J" & fa)
For Each C In r
CTO = CP.Cells(C.Row, 1).Value
If CTO = "FG BOOKED" Or CTO = "CLOSED" Then
ZV.Cells(C.Row, 1) = 0
ElseIf CTO = "NOT STARTED" Or CTO = "UNCONFIRMED" Then
ZV.Cells(C.Row, 1) = OD.Cells(C.Row, 1).Value
End If
Next C
I am using this code to go through my worksheet making a For loop to change value in Column H by referencing to Column J.
When this code is used on a standalone worksheet, it seems to work perfectly. But once I port it over to a much bigger file which has data connection, and I run this macro only individually, it causes my CPU to run at 100% and takes up to 10 minutes.
Does anyone know why this is happening?
To help your macro run smoother you can insert the below code before your main code (just below the sub) and right after your code (just before the end sub)
This will turn off screen updates, alerts, and set the calculation to manual so no formulas are updating until after the process has ran.
'Please Before Main Code'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
'Insert main code here'
'Place After Main code'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
It seems you fell in a trap which has the following features:
You are using a large excel file which is several MB in size
The excel document is full of formula and data connection
Additionally it might have pivot tables and charts
Calculation option for Formula is Automatic
Try this:
1. Go to formula tab
2. Click "Calculation Option"
3. Select "Manual"
Now execute the macro you have created. It should be good to go. Once the macro is executed. You can change the calculation option.
Note: You can control the calculation option problematically as well using below snippet:
Dim CalcMode As Long
' This will set the calculation mode to manual
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
<< Add your macro processing here >>
' Again switch back to the original calculation option
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
Excel tries to calculate the values (based on formula) everytime any cell is changed. This is done for the entire document for every cell updated by your macro. So, for large excel document, it causes high CPU consumption.
You are setting values of cells one at a time triggering a recalculation. The way to do this correctly is to read the columns into memory first, set the values and write the results with one operation.
Public Sub AnswerPost()
Dim r_status As Range, r_value As Range, r_calc As Range
Dim i As Long, n As Long
Dim op As Worksheet
Set op = Worksheets("ZVCTOSTATUS")
' Find the number of items on cell "J2" and below
n = Range(op.Range("J2"), op.Range("J2").End(xlDown)).Rows.Count
' Set the n×1 range of cells under "J", "G" and "H" columns
Set r_status = op.Range("J2").Resize(n, 1)
Set r_value = op.Range("G2").Resize(n, 1)
Set r_calc = op.Range("H2").Resize(n, 1)
Dim x_status() As Variant, x_value() As Variant, x_calc() As Variant
' Read cells from the worksheet into memory arrays
x_status = r_status.Value2
x_value = r_value.Value2
x_calc = r_status.Value2
' Set values of x_calc based on x_status, row by row.
For i = 1 To n
Select Case x_status(i, 1)
Case "FG BOOKED", "CLOSED"
x_calc(i, 1) = 0#
Case "NOT STARTED", "UNCONFIRMED"
x_calc(i, 1) = x_value(i, 1)
End Select
Next i
' Write the resulting array back into the worksheet
r_calc.Value2 = x_calc
End Sub
Test case for above code
I've tried tons of solutions and browsed the web for more for hours now. Maybe one of you can help.
I have a macro that selects all sheets with a specific string in their name, then prints them. If there are too many sheets, it freezes, and you are unabled to break the macro to debug, and Ctrl+Alt+Del is the only way out. It freezes at different locations each time too...
My original code:
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim x As Integer
For x = 1 To Worksheets.count
If VBA.InStr(Worksheets(x).Name, "Lateral Assessment") > 0 Then
With Worksheets(x).PageSetup
.Orientation = xlPortrait
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Worksheets(x).PrintOut
End If
Next x
Application.ScreenUpdating = True
Application.EnableEvents = True
I have tried, per other forum threads, the following:
Adding DoEvents in the loop to allow the system time to process
Adding a "Wait" timer to give it time to process
Looping through and setting the pagesetup properties first, then printing (it finishes the loop to set pagesetups fine, but freezes in the print loop like "normal"
Moved to adding all of the sheets to an array, then sending them as a single print job (it still freezes after 14-16 pages)
I also at one point added a progress bar I use in a lot of my bigger processes, and you can see it progressing through the count before freezing on an inconsistent sheet number. Additionally, note that the problem occurs even if I run it one iteration at a time from the VBA code window, thus, it appears that it is not related to processing time (although one cannot be certain of that).
My current code:
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim x As Long, iTotal As Long, sSheets() As String
iTotal = -1
For x = 1 To Worksheets.count
If VBA.InStr(Worksheets(x).Name, "Lateral Assessment") > 0 Then
With Worksheets(x).PageSetup
.Orientation = xlPortrait
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
iTotal = iTotal + 1
ReDim Preserve sSheets(iTotal)
sSheets(iTotal) = Worksheets(x).Name
End If
Next x
If iTotal <> -1 Then
Sheets(sSheets).PrintOut Copies:=1, Collate:=True
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Any idea why this is happening, and possible solutions that I havent tried?
Make sure ScreenUpdating is on. The VBA code is:
Application.ScreenUpdating = True
If it does hang, this works. Resize the printpreview window (grab the corner or edge and make it small then large again). This seems to cause Excel to kick into ScreenUpdating and gives you control back. Just in case, so you always have access to the edges of the window to do this, you can automatically resize Excel just before the printpreview with:
Sub WindowState_850x1400()
With Application
.WindowState = xlNormal
.Top = 1
.Left = 1
.Height = 850
.Width = 1400
End With
End Sub