As I said in the title, I'm wondering if someone can help me figure out why my code is running so slowly (Ran for an hour with no result). I'm very new when it comes to writing in VBA, but I don't see a reason why it would take so long. Here is the code in question:
Sub fast()
Application.ScreenUpdating = False
Dim prices As Worksheet
Dim stockreturns As Worksheet
Dim index As Worksheet
Dim stockprices As Range
Set index = Worksheets("IndexPrices")
Set prices = Worksheets("HistPrices")
Set stockreturns = Worksheets("Sheet1")
index.Range("A:B").Copy stockreturns.Range("A:B")
For col = 1 To 975
For n = 2 To 260
prices.Range("A:A").Offset(0, col).Copy stockreturns.Range("A:A").Offset(0, 2 * col + 1)
If stockreturns.Cells(n + 1, 2 * col).Value = Null Or IsEmpty(stockreturns.Cells(n + 1, 2 * col).Value) Then
stockreturns.Cells(n, 2 * col + 1) = Null
Else
stockreturns.Cells(n, 2 * col + 1).Formula = Cells(n, 2 * col) / Cells(n + 1, 2 * col) - 1
stockreturns.Cells(n, 2 * col + 1).NumberFormat = "0.00%"
End If
Next n
Next col
Application.ScreenUpdating = True
End Sub
I'd be happy to post the workbook if anyone wants to see what I'm trying to accomplish in the sheet and potentially suggest a different or more efficient way of doing it. Thanks.
Assuming your code did what you want, the below redrafting should be much quicker.
Avoid using .Copy wherever possible. Instead directly assign the .Value of cells.
Make sure your lines of code are within the correct loops to avoid running code more often than it has to be run.
Stop doing every operation on entire columns, that's a lot of cells you're copying, of which 99% will be blank! I've taken the most basic approach possible and chosen to just use the first 1000 rows, improve this as suits - possibly by finding the actual last row.
Disable the automatic Calculation as well as the ScreenUpdating.
See code comments for details.
Sub fast()
Application.ScreenUpdating = False
' Stop Excel from recalculating the workbook every time a cell value changes
Application.Calculation = xlCalculationManual
Dim prices As Worksheet, stockreturns As Worksheet, index As Worksheet
' Fully qualify your sheets by specifying the workbook
With ThisWorkbook
Set index = .Sheets("IndexPrices")
Set prices = .Sheets("HistPrices")
Set stockreturns = .Sheets("Sheet1")
End With
' Assign some last row number so you don't have to be copying the value of tens of thousands of rows
' Previously every values copy was on the entire column, wasting a lot of time!
' Could get this value by a cleverer, more dynamic method, but that depends on needs.
Dim lastrow As Long: lastrow = 1000
' Assign values, don't use copy/paste. Avoiding the clipboard speeds things up
stockreturns.Range("A1:B" & lastrow).Value = index.Range("A1:B" & lastrow).Value
For col = 1 To 975
' This line isn't affected by the value of n, so move it outside the n loop! Again, use .Value not copy
stockreturns.Range("A1:A" & lastrow).Offset(0, 2 * col + 1).Value = prices.Range("A1:A" & lastrow).Offset(0, col).Value
For n = 2 To 260
If stockreturns.Cells(n + 1, 2 * col).Value = Null Or IsEmpty(stockreturns.Cells(n + 1, 2 * col).Value) Then
stockreturns.Cells(n, 2 * col + 1) = Null
Else
stockreturns.Cells(n, 2 * col + 1).Formula = Cells(n, 2 * col) / Cells(n + 1, 2 * col) - 1
stockreturns.Cells(n, 2 * col + 1).NumberFormat = "0.00%"
End If
Next n
Next col
' Reset Application settings
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Main issue:
This nested loop of yours executes 975 * 260 = 253.500 times:
For col = 1 To 975
For n = 2 To 260
prices.Range("A:A").Offset(0, col).Copy stockreturns.Range("A:A").Offset(0, 2 * col + 1)
If stockreturns.Cells(n + 1, 2 * col).Value = Null Or IsEmpty(stockreturns.Cells(n + 1, 2 * col).Value) Then
stockreturns.Cells(n, 2 * col + 1) = Null
Else
stockreturns.Cells(n, 2 * col + 1).Formula = Cells(n, 2 * col) / Cells(n + 1, 2 * col) - 1
stockreturns.Cells(n, 2 * col + 1).NumberFormat = "0.00%"
End If
Next n
Next col
Summary of what you're doing, according to code in the question:
Basically, what you're doing is get column B, C, D, etc. and copy them to D, E, G, etc. using the offset. Next you check in the stockreturns worksheet what the value of the copied cell in the next row is (e.g. you check D3, then D4 etc.) and based on that populate E2, E3, etc. with nulls, or, alternatively you take ((D2 / D3) - 1) as a value there. The initial check is to avoid division by zero errors, I assume.
Note:
In those lines in your code you refer to Cells(n, 2 * col) so that would always be the ActiveSheet, whereas I assume you want to populate the worksheet stockreturns with those values. I.e. if you run the formula with worksheet prices activated, the formula's won't give the desired output.
Working towards solution:
For sure it would be way faster to not do 253.500 loops, but to populate everything at once for as far as possible. Since the column number varies everytime, we'll leave that loop in, but the nested 260 loops we can easily get rid of:
Optimization to do 975 loops instead of 253.500:
With stockreturns
For col = 1 To 975
prices.Range("A:A").Offset(0, col).Copy .Range("A:A").Offset(0, 2 * col + 1)
'Now we fill up the entire 260 rows at once using a relative formula:
.Range(.Cells(2, 2 * col + 1), .Cells(260, 2 * col + 1)).FormulaR1C1 = "=IF(R[+1]C[-1]="""","""",(RC[-1]/R[+1]C[-1])-1)"
'If you want a value instead of a formula, we replace the formula's with the value. If calculation is set to manual, you'll have to add an Application.Calculate here.
.Range(.Cells(2, 2 * col + 1), .Cells(260, 2 * col + 1)).Value = .Range(.Cells(2, 2 * col + 1), .Cells(260, 2 * col + 1)).Value
.Range(.Cells(2, 2 * col + 1), .Cells(260, 2 * col + 1)).NumberFormat = "0.00%"
Next col
End With
This will already save major execution time. However, we can also save ourselves 975 calculate actions, by turning off calculations and only replacing the formulas with the values at the very end:
Second optimization to avoid calculations during execution:
Application.Calculation = xlCalculationManual
With stockreturns
For col = 1 To 975
prices.Range("A:A").Offset(0, col).Copy .Range("A:A").Offset(0, 2 * col + 1)
'Now we fill up the entire 260 rows at once using a relative formula:
.Range(.Cells(2, 2 * col + 1), .Cells(260, 2 * col + 1)).FormulaR1C1 = "=IF(R[+1]C[-1]="""","""",(RC[-1]/R[+1]C[-1])-1)"
.Range(.Cells(2, 2 * col + 1), .Cells(260, 2 * col + 1)).NumberFormat = "0.00%"
Next col
End With
Application.Calculate
stockreturns.UsedRange.value = stockreturns.UsedRange.value
This last version runs in seconds.
If it is acceptable for you to alter the stockreturns worksheet layout and use a continuous range to copy to at once, you won't need those 975 loops either but you can achieve the desired result with the following actions:
Copy prices range
Add the formula in another range
Calculate
Replace formulas with values
Set numberformat
Hope this helps.
Before we move on the optimization, let's make sure at least it works. Please check where I comment.
Assume that code above is correct. And in your code, you just modify to 260 rows so that I set last row to 260. I think this will need deeper debug to work. but if you follow this way, it will end up your program finish much faster (like hundreds of time faster than all normal methods above)
The concept is similar.
1. Dump all data to memory ( array "stockdata and "pricedata")
2. Play with data in memory
3. write back to file
4. add format if required.
Sub fast()
Dim stockdata,pricedata As Variant
Application.ScreenUpdating = False
' Stop Excel from recalculating the workbook every time a cell value changes
Application.Calculation = xlCalculationManual
Dim prices As Worksheet, stockreturns As Worksheet, index As Worksheet
' Fully qualify your sheets by specifying the workbook
With ThisWorkbook
Set index = .Sheets("IndexPrices")
Set prices = .Sheets("HistPrices")
Set stockreturns = .Sheets("Sheet1")
End With
' Assign some last row number so you don't have to be copying the value of tens of thousands of rows
' Previously every values copy was on the entire column, wasting a lot of time!
' Could get this value by a cleverer, more dynamic method, but that depends on needs.
Dim lastrow As Long: lastrow = 260
' Assign values, don't use copy/paste. Avoiding the clipboard speeds things up
stockreturns.Range("A1:B" & lastrow).Value = index.Range("A1:B" & lastrow).Value
pricedata = prices.Range("A1",prices.Cells(lastrow,975))
redim stockdata(1 to lastrow, 1 to 1952)
For col = 1 To 975
'stockreturns.Range("A1:A" & lastrow).Offset(0, 2 * col + 1).Value = prices.Range("A1:A" & lastrow).Offset(0, col).Value
for n = 1 to lastrow
'offset so that +1
stockdata(n,col*2+1+1) = pricedata(n,col+1)
next n
next col
'done with that
'check value and change if need
For col = 1 To 975
For n = 2 To 260
If stockdata(n + 1, 2 * col) = Null Or IsEmpty(stockdata(n + 1, 2 * col)) Then
stockdata(n, 2 * col + 1) = Null
Else
stockdata(n, 2 * col + 1).Formula = stockdata(n, 2 * col) / stockdata(n + 1, 2 * col) - 1
'stockdata(n, 2 * col + 1).NumberFormat = "0.00%"
End If
Next n
Next col
stockreturns.Range("A1",stockreturns.Cells(lastrow,1952)) = stockdata
Dim rng As Range
Set rng = stockreturns.Range("B1:B" & lr)
For col = 2 To 975
Set rng = Union(rng, Range(stockreturns.Cells(1,2*col + 1),stockreturns.Cells(lr,2*col + 1),)
next n
rng.NumberFormat = "0.00%"
' Reset Application settings
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I'm new to VBA and was writing a simple code to take all numbers in column A and add 99 to those numbers in column B. However, as soon as it passes 1000, an overflow occurs. What can I do to cut off the while loop so it doesn't overflow the remaining columns with 99? Thanks!
Sub Button1_Click()
Dim n As Integer
n = 0
While Cells(1 + n, 1) <= 1000
If Cells(1 + n, 2) = 0 Then
Stop
End If
Cells(1 + n, 2).Value = Cells(1 + n, 1) + 99
n = n + 1
Wend
End Sub
maybe you're after this:
Dim cell As Range
For Each cell In Range("A:A").SpecialCells(xlCellTypeConstants, xlNumbers) '<--| loop through column A cells with constant numeric content
If cell.Value > 1000 Then Exit For '<--| exit loop as soon as the current cell value exceeds 1000
cell.Offset(, 1).Value = cell.Value + 99
Next
Im reading cell values from excel sheet and add it in datagridview.
I followed below code but it add only one row and it is the last row in excel sheet. I have four rows in excel sheet so datagridview also should have four rows.
For x = 9 To xlWorkSheet.UsedRange.Rows.Count
For j = 0 To LogCalcEnter.ColumnCount - 1
If Not String.IsNullOrEmpty(xlWorkSheet.Cells(1 + x, j + 1).Value) Then
LogCalcEnter.Rows.Add()
LogCalcEnter.Item(j, 0).Value = xlWorkSheet.Cells(1 + x, j + 1).value
End If
Next
Next
LogCalcEnter is name of the Datagridview
You add a new row for every column that you are looping over. The code below creates a new row for each row you loop over. I changed LogCalcEnter.Item(j, 0) to LogCalcEnter.Item(j, rowIndex) so that you're filling out the row information too. Note: I haven't actually run it, you may have issues with the indices you are using in this. You say you have 4 rows in the spreadsheet but you started with x = 9. Also the +1's in xlWorkSheet.Cells(1 + x, j + 1).Value) push the row count over the amount in UsedRange.
For x = 1 To xlWorkSheet.UsedRange.Rows.Count
Dim rowIndex = LogCalcEnter.Rows.Add()
Dim hasValue = False
For j = 0 To LogCalcEnter.ColumnCount - 1
If Not String.IsNullOrEmpty(xlWorkSheet.Cells(1 + x, j + 1).Value) Then
hasValue = True
LogCalcEnter.Item(j, rowIndex).Value = xlWorkSheet.Cells(1 + x, j + 1).value
End If
Next
If Not hasValue Then LogCalEnter.Rows.RemoveAt(rowIndex)
Next
For j = 1 To 8
Sheet5.Cells(j + 1, 2) = 480
Next
t = 0
c = 0
For j = LBound(arrayTime) + 1 To UBound(arrayTime)
MsgBox "j " & j
'MsgBox (t)
numMins = Sheet5.Cells((j + 1) - (8 * c), 2) - arrayTime(j)
If numMins < 0 Then
t = t + 1
ReDim Preserve arrayTime(numrows - 1 + t)
arrayTime(numrows - 1 + t) = arrayTime(j)
MsgBox (arrayTime(numrows - 1 + t))
Else
Sheet5.Cells((j + 1) - (8 * c), 2) = numMins
End If
If j = 8 * (c + 1) Then
c = c + 1
End If
MsgBox ("end " & t)
Next
Im trying to add an value to arrayTime if the condition is true. I successfully added it but the for loop will not re-dimension to loop through the added element. The array originally contains 12 elements then I add a 13th but the loop does to recognize the 13th element and only loops 12 times. Any suggestions on how to get the for loop to loop 13 times?
Add a loop counter, say i, and set it to LBound(arrayTime) + 1 then use a Do Until (i = UBound(arrayTime)). This forces VBA to recalculate the upper bound before each loop.
I would appreciate some help on the following VBA Macro problem,
screenshot here:
I have to compare the data in 2 columns - Index & Sec_Index. In case of a match it should check which Values is assigned to the Sec_Index and fill a "1" to the matching Value column corresponding to Index and "0" for the other Value columns (I hope the screenshot explains it better)
I wrote a short macro which works good. However I have huge amounts of data - both Index columns contain at least 400000-500000 lines. This makes my code useless since it will take extreme long durations to execute.
Is there a way to make this work? I read about Variant arrays, but I'm not that familiar with them.
You can put this formula (if Excel 2007 or above):
=COUNTIFS($H$2:$H$5,$B2,$I$2:$I$5,"A")
into C2 and copy it down and across; just change "A" to "B" and "C".
Added In view of the number of rows, I would import the data into MS Access, create a Crosstab Query, then copy this data back to Excel.
Try this, not overly robust but does work. Not sure how quickly this will compare to what you may have had?
It did about 60,000 rows with 25 keys in about 5 seconds.
Edit: Added timer to function.
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
public Sub main()
Dim t As Long
t = GetTickCount
Application.ScreenUpdating = False
Dim Arr1(), Arr() As Double
Dim x, y, i, j As Double
Dim v As String
x = Cells(Rows.Count, 2).End(xlUp).Row - 2
y = Cells(Rows.Count, 8).End(xlUp).Row - 2
Range("c2", "e" & x + 2) = 0
ReDim Arr1(x)
ReDim Arr2(y)
i = 0
Do Until Cells(i + 2, 2) = ""
Arr1(i) = Cells(i + 2, 2)
i = i + 1
Loop
i = 0
Do Until Cells(i + 2, 8) = ""
Arr2(i) = Cells(i + 2, 2)
i = i + 1
Loop
i = 0
Do Until i > UBound(Arr1)
j = 0
Do Until j > UBound(Arr2)
If Arr1(i) = Arr2(j) Then
v = Cells(Arr2(j) + 1, 9)
Select Case v
Case "a"
Cells(i + 2, 3) = 1
Case "b"
Cells(i + 2, 4) = 1
Case "c"
Cells(i + 2, 5) = 1
End Select
Exit Do
End If
j = j + 1
Loop
i = i + 1
Loop
MsgBox GetTickCount - t, , "Milliseconds"
End Sub