I have an excel spreadsheet with about 300,000 records. I am applying a Vlookup formula on the first row and then trying to copy and paste special as formulas to the remaining rows. But, the calculation tends to consume a lot of time and shows progress in multi-threads which is really slow.
Could someone suggest a way to do this to save some time.
Thank you!
Assuming you need to do an exact match lookup then the fastest formula way to do this is to sort your data and then use the double VLOOKUP trick.
see my blog post for details:
https://fastexcel.wordpress.com/2012/03/29/vlookup-tricks-why-2-vlookups-are-better-than-1-vlookup/
If you're stuck with it, your best bet is to optimize your formulas by avoiding common pitfalls. You've mentioned that you're using VLOOKUP, why not try INDEX/MATCH combo, it is more versatile and is faster than VLOOKUP. Other optimizing techniques include:
avoiding volatile formulas
using helper columns
arrange the columns in such a way that the sequence of your calculation is from left to right, top to bottom, very much like reading English text
Use structured and named references
Enable manual calculation so that formulas are not recalculated every time you make even the slightest change
You may also want to use a timer to measure Excel calculation time, for you to compare your different approaches, such as this one by Charles Williams, from an article in Microsoft Developer Network. Paste this code into the VBA editor:
#If VBA7 Then
Private Declare PtrSafe Function getFrequency Lib "kernel32" Alias _
"QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare PtrSafe Function getTickCount Lib "kernel32" Alias _
"QueryPerformanceCounter" (cyTickCount As Currency) As Long
#Else
Private Declare Function getFrequency Lib "kernel32" Alias _ "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare Function getTickCount Lib "kernel32" Alias _
"QueryPerformanceCounter" (cyTickCount As Currency) As Long
#End If
Function MicroTimer() As Double
'
' Returns seconds.
Dim cyTicks1 As Currency
Static cyFrequency As Currency
'
MicroTimer = 0
' Get frequency.
If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
getTickCount cyTicks1
' Seconds
If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function
Sub RangeTimer()
DoCalcTimer 1
End Sub
Sub SheetTimer()
DoCalcTimer 2
End Sub
Sub RecalcTimer()
DoCalcTimer 3
End Sub
Sub FullcalcTimer()
DoCalcTimer 4
End Sub
Sub DoCalcTimer(jMethod As Long)
Dim dTime As Double
Dim dOvhd As Double
Dim oRng As Range
Dim oCell As Range
Dim oArrRange As Range
Dim sCalcType As String
Dim lCalcSave As Long
Dim bIterSave As Boolean
'
On Error GoTo Errhandl
' Initialize
dTime = MicroTimer
' Save calculation settings.
lCalcSave = Application.Calculation
bIterSave = Application.Iteration
If Application.Calculation <> xlCalculationManual Then
Application.Calculation = xlCalculationManual
End If
Select Case jMethod
Case 1
' Switch off iteration.
If Application.Iteration <> False Then
Application.Iteration = False
End if
' Max is used range.
If Selection.Count > 1000 Then
Set oRng = Intersect(Selection, Selection.Parent.UsedRange)
Else
Set oRng = Selection
End If
' Include array cells outside selection.
For Each oCell In oRng
If oCell.HasArray Then
If oArrRange Is Nothing Then
Set oArrRange = oCell.CurrentArray
End If
If Intersect(oCell, oArrRange) Is Nothing Then
Set oArrRange = oCell.CurrentArray
Set oRng = Union(oRng, oArrRange)
End If
End If
Next oCell
sCalcType = "Calculate " & CStr(oRng.Count) & _
" Cell(s) in Selected Range: "
Case 2
sCalcType = "Recalculate Sheet " & ActiveSheet.Name & ": "
Case 3
sCalcType = "Recalculate open workbooks: "
Case 4
sCalcType = "Full Calculate open workbooks: "
End Select
' Get start time.
dTime = MicroTimer
Select Case jMethod
Case 1
If Val(Application.Version) >= 12 Then
oRng.CalculateRowMajorOrder
Else
oRng.Calculate
End If
Case 2
ActiveSheet.Calculate
Case 3
Application.Calculate
Case 4
Application.CalculateFull
End Select
' Calculate duration.
dTime = MicroTimer - dTime
On Error GoTo 0
dTime = Round(dTime, 5)
MsgBox sCalcType & " " & CStr(dTime) & " Seconds", _
vbOKOnly + vbInformation, "CalcTimer"
Finish:
' Restore calculation settings.
If Application.Calculation <> lCalcSave Then
Application.Calculation = lCalcSave
End If
If Application.Iteration <> bIterSave Then
Application.Iteration = bIterSave
End If
Exit Sub
Errhandl:
On Error GoTo 0
MsgBox "Unable to Calculate " & sCalcType, _
vbOKOnly + vbCritical, "CalcTimer"
GoTo Finish
End Sub
You may also check the links under References for more suggestions and techniques in optimizing Excel performance. Although in the second link, it said:
"It is usually faster to use the Excel formula calculations and worksheet functions than to use VBA user-defined functions."2
Although this may be true if we're talking about the process of calculation itself but if you do your calculations in VBA, your output will be static. So if you're doing let's say financial modelling, what-if scenarios, and such, it'll be painful to wait for 15 minutes for each minute changes if automatic calculation is enabled because the formulas are actively referencing the cells, monitoring for any changes.
Hope this helps..
References:
Excel performance: Improving calculation performance
Excel performance: Tips for optimizing performance obstructions
Excel performance: Performance and limit improvements
Related
Let's say I want to click in a certain sheet of an excel file on cells:
A1 - 3 times
A2 - 5 times
B1 - 10 times
B2 - 20 times
I'd like the output to show the number of clicks in each cell, as I am clicking them (https://i.stack.imgur.com/1KfHT.png). How can I obtain this? I've been trying many variants of the code below, without success.
Many thanks!
Sub Worksheet_SelectionChange(ByVal Target As Range)
For Each cell In Range("A1:B2")
xNum = 0
On Error Resume Next
Set myRange = cell
If cell Is Nothing Then Exit Sub
If Intersect(myRange, Target) Is Nothing Then Exit Sub
xNum = xNum + 1
MyRange.Value = xNum
Next cell
End Sub
Count the Number of Clicks on Each Cell of a Range...
... and write the count to the clicked cell.
Upon clicking a cell of the source range, the value in the cell is increased by one and the cell and the last cell of the worksheet become selected.
The idea was taken from Super Simmetry's answer to the question "OnClick in Excel VBA".
The idea, of how to exclude the navigation keys to trigger the event, was taken from Jaafar Tribak's first answer to the question "Mouse click event". He has also posted another (newer) post as an improvement which I haven't studied but looks promising (in getting rid of the 'hack' part).
Since this doesn't do exactly what is required, your feedback is highly appreciated.
Copy the complete code into the sheet module (e.g. Sheet1) of the worksheet to where it needs to be applied.
There's nothing to run, it runs automatically upon each click on a cell in the worksheet.
Option Explicit
' This declaration may be wrong!!!
' It's working in my 64bit Office 2019 using Windows 10 64bit.
#If VBA7 Then
Private Declare PtrSafe Function GetAsyncKeyState _
Lib "user32" (ByVal vKey As Long) As Integer
#Else
Private Declare Function GetAsyncKeyState _
Lib "user32" (ByVal vKey As Long) As Integer
#End If
Private Const RangeAddress As String = "A1:B2"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls: CountRangeClicks
' WasNavigationKeyPressed
' GetAsyncKeyState
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub WorkSheet_SelectionChange(ByVal Target As Range)
CountRangeClicks Target, RangeAddress
End Sub
' To reset the values to zero upon double-clicking any of the source cells,
' you could use the following event procedure.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim srg As Range: Set srg = Me.Range(RangeAddress)
If Intersect(srg, Target) Is Nothing Then Exit Sub
srg.Value = 0
Cancel = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls: WasNavigationKeyPressed
' GetAsyncKeyState
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CountRangeClicks( _
ByVal Target As Range, _
ByVal RangeAddress As String)
If WasNavigationKeyPressed Then Exit Sub ' only 'mouse-selection'
If Target.Cells.CountLarge > 1 Then Exit Sub ' only one cell selection
Dim ws As Worksheet: Set ws = Target.Worksheet
Dim srg As Range: Set srg = ws.Range(RangeAddress)
If Intersect(srg, Target) Is Nothing Then Exit Sub
' The Hack (Not quite what is required)
' The trick is in selecting the target cell ('tCell') and another cell
' (I've opted for the last cell in the worksheet)('uCell').
' For more detail, see Super Symmetry's post at
' https://stackoverflow.com/a/61377786
Dim tCell As Range: Set tCell = Target
Dim uCell As Range: Set uCell = ws.Cells(ws.Cells.CountLarge)
Application.EnableEvents = False
Union(tCell, uCell).Select
Application.EnableEvents = True
' Only if any of the source cells ('srg') is clicked on,
' the last worksheet cell becomes selected with it.
' Validate and count (write).
Dim tValue As Variant: tValue = tCell.Value
Dim IsWholeNumber As Boolean
If VarType(tValue) = vbDouble Then ' is a number
If Int(tValue) = tValue Then ' is an integer
If tValue >= 0 Then ' is a whole number (0, 1, 2...)
IsWholeNumber = True
End If
End If
End If
If IsWholeNumber Then
tCell.Value = tCell.Value + 1
Else
tCell.Value = 1
End If
End Sub
' Calls the 'GetAsyncKeyState' Windows API
' Not entirely sure what's going on here (`And &H8000`)!!!
' For more detail, see Jaafar Tribak's post at
' https://www.mrexcel.com/board/threads/mouse-click-event.208072
Function WasNavigationKeyPressed() As Boolean
Dim NavigationKeys As Variant: NavigationKeys = Array( _
vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, _
vbKeyTab, vbKeyReturn, vbKeyHome, vbKeyEnd, vbKeyPageDown, vbKeyPageUp)
Dim Item As Variant
For Each Item In NavigationKeys
If CBool(GetAsyncKeyState(Item) And &H8000) Then
WasNavigationKeyPressed = True
Exit Function
End If
Next Item
End Function
Is this what you're after?
Sub Worksheet_SelectionChange(ByVal Target As Range)
' declare range
Dim MyRange As Range
' range to check for clicks
Set MyRange = Me.Range("A1:A2")
' ensure cell selected is within MyRange, drop out if not
If Intersect(MyRange, Target) Is Nothing Then Exit Sub
' increment +1 the value of the cells, offset to the right by one
Target.offset(0, 1).Value = Target.offset(0, 1).Value + 1
' disable events to prevent loop (not entirely necessary, but wise)
Application.EnableEvents = False
' change activated cell one to the right to allow re-click
Target.offset(0, 1).Activate
' enable events
Application.EnableEvents = True
End Sub
I have a range of time values in cell Range D2 to D12.
For example, D2 contains "12:30:00 PM" and D3 contains "1:30:00 PM". Some cells in the range may not contain any time so this is dynamic.
I would like to run a macro if current time (now) matches any of the time in the range.
Something like this:
if Now() = "Any time in the range" Then
run a macro
End if
I have been trying to apply the below. The code is from here Scheduling macros. But I also observed that the Application.Wait function does a better job compared to using the Application.OnTime. I need help with applying the Application.Wait function to run a macro at specified times in a range.
Public ScheduledTime As Double
Public Const Interval = 5
Public Const MyProc = "MyCode"
Sub MyCode()
Debug.Print Now()
SetOnTime
End Sub
Sub SetOnTime()
ScheduledTime = Now + TimeSerial(0, 0, Interval)
Application.OnTime ScheduledTime, MyProc
End Sub
After hunting and finding no perfect solution, I'm privileged to build one
Public ScheduledTime As Double
Public Const MyProc = "MyCode"
Sub MyCode()
'Macro to run
Debug.Print "Hello, this is a scheduled macro" & " " & Format(ScheduledTime, "hh:mm:ss AM/PM")
'Stop
End Sub
Sub SetOnTime()
Dim myArray As Variant, i As Long, numOfTimes As Long
Dim nextTime, newTime, waitTime
'Declare array
myArray = Range("D2:K5").Value
'Remove empty array values to get the exact number of values
'allow room for dynamic range
numOfTimes = Application.WorksheetFunction.CountA(Range("D2:K5"))
'Loop through array values
For i = 1 To numOfTimes
'get the earliest time from the array
nextTime = Application.WorksheetFunction.Small(myArray, i)
ScheduledTime = nextTime
'Make it possible to change (add or subtract from) scheduled time
waitTime = ScheduledTime + TimeSerial(0, 0, 0)
' Show next time in Status bar
Application.DisplayStatusBar = True
Application.StatusBar = "Next Runtime: " & waitTime
'Make program wait till waitTime and run code
Application.Wait waitTime
MyCode
Next i
End Sub
When I try to copy-paste some existing shapes into cells depending on the value of the cells, my macro will fail after few copies (less than 10) with the following error:
Run-time error '-2147221040 (800401d0)': Automation error
OpenClipboard Failed
I initially thought that might be some kind of Clipboard buffer issue so I added this command after each paste:
Application.CutCopyMode = False
But it didn't change anything.
But then I noticed that if put some breakpoint on my code and run it "step-by-step" (F5 when at the breakpoint), it works fine... as long as I don't press F5 too quickly.
In the end I added a wait of 1s after each Paste, and this way the code runs without any error till the end (but crazy slow for a few thousands paste).
Below the code I currently run:
Sub Change_to_icon()
Dim cell As Range
For Each cell In ActiveSheet.Range("C4:AI28")
If cell.Value = "" Then
cell.Value = "0"
ElseIf cell.Value = "1" Then
ActiveSheet.Shapes("CD").Copy
cell.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.Wait (Now + TimeValue("0:00:01"))
ElseIf cell.Value = "2" Then
ActiveSheet.Shapes("CDW").Copy
cell.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.Wait (Now + TimeValue("0:00:01"))
ElseIf cell.Value = "3" Then
ActiveSheet.Shapes("E").Copy
cell.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.Wait (Now + TimeValue("0:00:01"))
ElseIf cell.Value = "4" Then
ActiveSheet.Shapes("CT").Copy
cell.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.Wait (Now + TimeValue("0:00:01"))
End If
Next cell
End Sub
In some other topics someone was suggesting in some rather similar situation than there may be a discrepancy in the loop like trying to paste before copy (I fI understood well), and to add some DoEvents. I also tried this at different places in the code. Didn't change anything.
Also, all the new shapes pasted have similar names, I could imagine that it has some unexpected side effect somewhere but I didn't try to give them a new name for each Paste.
What do you think is happening when it's running full speed without the Wait?
Instead of Copy&Paste, you can use Shape.Duplicate. The following code took less than 2s to copy more than 1000 shapes on my computer:
With ActiveSheet
Dim cell As Range
For Each cell In .Range("C4:AI28")
Dim shapeName As String
shapeName = ""
Select Case cell.Value
Case 0: cell.Value = 1
Case 1: shapeName = "CD"
Case 2: shapeName = "CDW"
(...)
End Select
If shapeName <> "" Then
Dim shCopy As Shape
Set shCopy = .Shapes(shapeName).Duplicate
shCopy.Left = cell.Left
shCopy.Top = cell.Top
shCopy.Name = shapeName & "_" & cell.Address(False, False)
End If
Next cell
End With
I had this inconvenient, looks like the clipboard gets stuck when it's trying to do the copy and paste, after playing a while a found something that helps me.
First, set a function to set a delay time
If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub prcWaiting(ByVal Mili_Seconds&)
Sleep Mili_Seconds
End Sub
I create a function that will do specifically the copy, and set and error handler to know if the copy was made or not if was made go true otherwise with an error false
Private Function funCopyMinusButton() As Boolean
On Error GoTo ErrHandler
Sheets("_Resources").Shapes("btnMinus").Copy
funCopyMinusButton = True
Done:
Exit Function
ErrHandler:
funCopyMinusButton = False
End Function
Where the code of copy is required I put some sort of cycle if the function returns false I give 2 seconds to Excel to release the clipboard and then try again the copy, sometimes may be in the cycle for couple of seconds and then continues the copy-paste process
errTry:
If Not funCopyMinusButton Then
prcWaiting 2000
GoTo errTry
End If
I hope this works for others with same error.
What I am trying to achieve here is I have three different dashboards running in all the three sheet which I was to switch every 1 Min. I am stuck with the below code. Any help would be appreciated.
I have three sheets to switch between
1. First_sheet, 2. Second_Sheet, 3. Third_Sheet
Sub Swap_Sheets()
Dim Sheets As Workbook
Dim dTime As Date
dTime = Now + TimeValue("00:00:60")
Application.OnTime dTime, "Swap_Sheets"
If ActiveSheet.Name = "First_Sheet" Then
Sheets("Second_Sheet").Activate
Else
Sheets("Third_Sheet").Activate
Else
Sheets("First_Sheet").Activate
End If
If Sheets("Second_sheet").CheckBox1.Value = False Then
Application.OnTime dTime, "Swap_Sheets", , False
End If
End Sub
This is a good way to do it, avoiding multiple if-s,select case and recursion:
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub SwapSheets()
Dim dTime As Date
Dim i As Long: i = 1
While i <= ThisWorkbook.Worksheets.Count
If ActiveSheet.Name = Worksheets(Worksheets.Count).Name Then
Worksheets(1).Activate
Else
Worksheets(ActiveSheet.index + 1).Activate
End If
i = i + 1
Sleep (10000) '10 seconds
Wend
End Sub
The idea is that every sheet has an index, and you simply have to increment the index of the active one. If the last sheet is the activeone, start from the beginning. Sleep takes milliseconds as a parameter, for 60 seconds it is 60.000.
Plus - in your code you have Dim Sheets As Workbook and here you probably mean Worksheet (I am only guessing).
If you only want to activate 3 worksheets, this is probably the easiest way to do it:
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub SwapSheets()
Dim sheetNames() As Variant
Dim i As Long
sheetNames = Array("Sheet1Name", "Sheet2Name", "Sheet3Name")
For i = LBound(sheetNames) To UBound(sheetNames)
Sheets(sheetNames(i)).Activate
Sleep (10000) '10 seconds
Next i
End Sub
I have a worksheet that automatically gets updated with live stock price data. At the moment we have a very messy solution of copying periodically to the clipboard and manipulating the data from there.
Is it possible to instead automatically export data to CSV every time a price change is detected? I'm guessing it would involve VBA.
You can treat excel file as a data source and you may query it.
See google results: http://www.google.ro/#sclient=psy&hl=ro&q=excel+data+source+sql+query&aq=0&aqi=g1&aql=&oq=&pbx=1&fp=b0efac6ab816e29b
I will try to find a specific article for you.
I'd suggest the following strategy:
Fire up your worksheet and switch into "design mode"
Right-click the button which updates the stock info and try to find out to which macro the button is bound to
Open the VBA editor (ALT+F11)
Choose the "Workbook"-Section
From there select the "Open" Event/Method
Write a simple loop with a delay which calls the macro mentioned above periodically and programmatically save the excel-sheet as CSV
The code would be somthing like this (can't check it as I don't have access to excel right now):
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub Workbook_open()
Do While True
Call name_of_macro()
ActiveWorkbook.SaveAs Filename:= _
"c:\path/to/file.csv", FileFormat:=xlCSV _
, CreateBackup:=False
Sleep 10000 'Sleep 10 seconds
Loop
End Sub
This example is just intended to show a rough solution. As Jean-Francois pointed out, this piece of code will NOT update everytime a change is detected, it will update every 10 seconds, even if the data is still the same.
You can use an Application.OnTime to set up a function to get called on a regular basis.
The following function gets called by Excel every 30 seconds. Either call it once to kick off the schedule or just set Application.OnTime once when your worksheet opens to get it running.
Public Sub DoExport()
' do your export to CSV logic here
Application.OnTime Now + TimeValue("00:00:30"), "DoExport"
End Sub
This will do the trick:
Sub LoadNewValuesAndCheckForChange()
Dim rngMyValues As Range
Dim varBefore As Variant
Dim varAfter As Variant
Dim iRow As Long
Dim iCol As Long
Dim booValuesHaveChanged As Boolean
Set rngMyValues = Range("B4:D9") ' Or wherever your data is
varBefore = rngMyValues ' Save old values in an array
' Call the function that loads your new stock prices here...
varAfter = rngMyValues ' Get new values
' Loop through all cells to see if anything has changed.
booValuesHaveChanged = False
For iRow = LBound(varBefore, 1) To UBound(varBefore, 1)
For iCol = LBound(varBefore, 21) To UBound(varBefore, 21)
If Not varAfter(iRow, iCol) = varBefore(iRow, iCol) Then
' Change detected!
booValuesHaveChanged = True
End If
Next iCol
Next iRow
If booValuesHaveChanged Then
' Save .csv file with timestamp in filename
ActiveWorksheet.SaveAs _
Filename:="c:\myfile" & Format(Now, "yyyymmddhhnnss") & ".csv", _
FileFormat:=xlCSV
End If
End Sub