First of all, I´m a pretty new and ineffective VBA user, which you´ll definitely notice.
I have created a macro with loops that runs extremely slowly (about 10 minutes depending on the dataset, which differs in size every time) and I´m guessing that there´s a much better way of doing it than mine.
Basically, what I´m trying to do is automate a job that includes a lot of built-in functions in Excel. I got four columns and X amount of rows that need to be populated with formulas.
My idea was to calculate the formula for all four columns in row 1, then moving on to row 2 all the way to row X, using a simple "do loop". It looks something like this:
Range("j2").Select
rownumber = ActiveCell.Row
Do
'check if the cell on the left is empty to determine whether it´s the last row or not.
Range("J" & rownumber).Select
Range("J" & rownumber).Offset(0, -1).Select
If IsEmpty(ActiveCell) = True Then
Exit Do
Else
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = _ "=INDEX(Sheet1!C[-4],MATCH(Sheet2!R[0]C[-6],Sheet1!C[-9],0))"
'next column
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = _ "=INDEX(sheet1!C[-6],MATCH(sheet2!RC[-7],sheet1!C[-10],0))"
'next column
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = _ "=INDEX(sheet3!C[-10],MATCH(sheet2!RC[-2],sheet1!C[-11],0))*sheet2!RC[-1]*sheet2!RC[-10]"
'next column
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = _ "=IF(sheet2!RC[-12]=""BUY"",SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])+sheet2!RC[-11],SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])-sheet2!RC[-11])"
ActiveCell.Offset(0, 1).Select
rownumber = rownumber + 1
End If
Loop
This all works, but there must be a better solution that runs smoother. I understand that Excel needs to do lots of calculations with the nested if statements, but it would probably take me less than 10 minutes to do this manually, so I´m guessing it´s my code that slows things up.
I would modify your code this way:
Dim xlcOld As Calculation: xlcOld = Application.Calculation
Application.Calculation = xlCalculationManual
Dim rownumber As Long: rownumber = 2
Do While Not IsEmpty(Range("I" & rownumber).Value)
Range("J" & rownumber).FormulaR1C1 = "=INDEX(Sheet1!C[-4],MATCH(Sheet2!R[0]C[-6],Sheet1!C[-9],0))"
Range("K" & rownumber).FormulaR1C1 = "=INDEX(sheet1!C[-6],MATCH(sheet2!RC[-7],sheet1!C[-10],0))"
Range("L" & rownumber).FormulaR1C1 = "=INDEX(sheet3!C[-10],MATCH(sheet2!RC[-2],sheet1!C[-11],0))*sheet2!RC[-1]*sheet2!RC[-10]"
Range("M" & rownumber).FormulaR1C1 = "=IF(sheet2!RC[-12]=""BUY"",SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])+sheet2!RC[-11],SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])-sheet2!RC[-11])"
rownumber = rownumber + 1
Loop
Application.Calculation = xlcOld
Note that:
Automatic recalculation is turned off, so only one recalculation is needed instead of 4 × rownumber calculations
Select operations are replaced with direct cell references
As BigBen indicated, it can be even more efficient by writing formulas in one go:
Dim xlcOld As Calculation: xlcOld = Application.Calculation
Application.Calculation = xlCalculationManual
Dim firstrow As Long: firstrow = 2
Dim lastrow As Long: lastrow = firstrow
Do While Not IsEmpty(Range("I" & lastrow).Value)
lastrow = lastrow + 1
Loop
lastrow = lastrow - 1
Range("J" & firstrow & ":J" & lastrow).FormulaR1C1 = "=INDEX(Sheet1!C[-4],MATCH(Sheet2!R[0]C[-6],Sheet1!C[-9],0))"
Range("K" & firstrow & ":J" & lastrow).FormulaR1C1 = "=INDEX(sheet1!C[-6],MATCH(sheet2!RC[-7],sheet1!C[-10],0))"
Range("L" & firstrow & ":J" & lastrow).FormulaR1C1 = "=INDEX(sheet3!C[-10],MATCH(sheet2!RC[-2],sheet1!C[-11],0))*sheet2!RC[-1]*sheet2!RC[-10]"
Range("M" & firstrow & ":J" & lastrow).FormulaR1C1 = "=IF(sheet2!RC[-12]=""BUY"",SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])+sheet2!RC[-11],SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])-sheet2!RC[-11])"
Application.Calculation = xlcOld
Whether this adds significant benefit, depends on the actual data. I think most of the work comes from recalculations and not from modifying the formulas but if rownumber is a really big number a further enhancement may be possible.
Also, you could find the last row with Range.End(xlUp) but that depends on the actual layout of your sheet, so I did not remove the loop counting the number of rows.
Related
Very new to VBA and macros. Looking to build a macro that will cut the items in G2:H2, paste them in I2:J2, skip to the next even numbered row, cut those items (G4:H4), paste those into I4:J4, and so-on until the end of the spreadsheet. The spreadsheet has roughly 11200 rows to sort through. Any help is GREATLY appreciated!
Sub TotalMove()
'
' TotalMove Macro
a = 2
g = Sheet17.Cells(Rows.Count, "A").End(xlUp).Row
For a = 2 To g Step 2
Range("G2:H2").Select
Selection.Cut
Range("I2:J2").Select
ActiveSheet.Paste
Next a
End Sub
You almost had it, was just a case of using your row number in the loop.
I made the variable names obvious for demo, set values rather than copy-paste, and specified the sheet in ranges.
Sub TotalMove()
With Sheet17
StartRow = 2
EndRow = .Cells(Rows.Count, "G").End(xlUp).Row
For CurrentRow = StartRow To EndRow Step 2
.Range("I" & CurrentRow & ":J" & CurrentRow) = .Range("G" & CurrentRow & ":H" & CurrentRow).Value
.Range("G" & CurrentRow & ":H" & CurrentRow).Clear
Next CurrentRow
End With
End Sub
I am trying to replicate in VBA the simple function in excel which allows you to repeat a function through an entire column, and stops when the columns on the side are empty. Specifically, I want to repeat an if - else if function for the entire relevant part of the column
Here's an attempt which does not really work
Sub RepeatIfElseif
Range("A1").Select
If selection > 0 Then
Range("B1").Select
ActiveCell.FormulaR1C1 = "X"
Range("A1").Select
ElseIf selection <= 0 Then
Range("B1").Select
ActiveCell.FormulaR1C1 = "Y"
End If
Range("B1").Select
selection.AutoFill Destination:=Range("B1:B134")
Is there any way I can do it with a loop?
You do not need to loop to drop formulas in. You just need to know where the last row is!
Pick a column that is most likely to represent your last row (I am using Column A in my example) and then you can dynamically drop-down your equation in one line without the loop.
The below will fill in the equation A2 + 1 in Column B starting from 2nd row (assuming you have a header row) down to the last used row in Column A
Option Explicit
Sub Formula_Spill()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update sheet!
Dim LR As Long
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row '<-- Update column!
ws.Range("B2:B" & LR).Formula = "=A2+1" '<-- Update formula!
End Sub
If you want to use a loop, you can use something like the code below:
For i = 1 To 134
If Range("A" & i).Value > 0 Then
Range("B" & i).FormulaR1C1 = "X"
Else
Range("B" & i").FormulaR1C1 = "Y"
End If
Next I
It can be done without a loop, something like:
Range("B1:B134").Formula = "=IF(A1>0," & Chr(34) & "X" & Chr(34) & "," & Chr(34) & "Y" & Chr(34) & ")"
Not sure what formula you are trying to achieve with .FormulaR1C1 = "Y" ?
I'm trying to improve my English, I swear...
I would do something like this:
dim row as long
dim last_row as Long
last_row = ActiveSheet.Range("A1048576").End(xlUp).Row
For row = 1 to last_row
If Range("A" & row).Value > 0 Then
ActiveSheet.Range("B" & row).Value = "X"
Else
ActiveSheet.Range("B" & row).Value = "Y"
End If
Next row
Hope this helps.
I would like to write perfectly working code but am faced with this issue. I want to transfer the data as values to another sheet. To fill out the data I use a form with formulas inside cells.
Then every time I click to transfer the data to another sheet it replaces the source data with its values in both sheets, but for me need that forms cells in the sheet1 stay unchanged. I use a form with formula to put data in the sheet1 from different sources, so it should work every time then I use it (now, after each click I have to recover formulas in the sheet1).
Here is the code:
Sub Button4_Click()
Dim x As Long
Dim erow as Long
'Calculate starting rows
x = 15
With Worksheets("Sheet2")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
End With
With Worksheets("Sheet1")
Do While .Cells(x, 1) <> ""
'Current code replaces the source data with its values'
.Range("A" & x & ":Y" & x).Value = .Range("A" & x & ":Y" & x).Value
'The next line copies values to Sheet2
Worksheets("Sheet2").Range("A" & erow & ":Y" & erow).Value = .Range("A" & x & ":Y" & x).Value
'increment row counters
x = x + 1
erow = erow + 1
Loop
End With
End Sub
You can't write to a cell's .Formula and then add unrelated data to the same cell's .Value - writing to .Value deletes the formula.
So the following code line:
.Range("A" & x & ":Y" & x).Value = .Range("A" & x & ":Y" & x).Value
is unnecessary (and damaging).
I am trying to create a time tracker that will be used to track associates time on any given task. I want to set it up so that the buttons to start and stop time are on the first sheet and the actual data being generated is on the next sheet. The code I have works, but it is just putting the data in the same sheet as the button. Here is what I have:
Sub StartBooking()
Dim lr As Long
lr = Range("a" & Rows.Count).End(xlUp).Row
Range("a" & lr + 1).Formula = "=now()"
Range("b" & lr + 1) = "Booking"
Range("c" & lr + 1) = "Start"
Range("a" & lr + 1).Select
Selection.Copy
Range("d" & lr + 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub
I know that this is extremely simple so let me add a disclaimer. Any knowledge of excel vba I have is completely self taught. I am new to coding (this is my first project) and find it very interesting, but I'm in way over my head. Please help!
By default data gets put on the ActiveSheet. You need to explicitly call out to the worksheet that you want to want to put the data onto. You can do this by calling the specific name of the sheet or the indexed position of the sheet. The indexed position is where the sheet is currently with respect to the other sheets.
Sub StartBooking()
Dim lr As Long
lr = Range("a" & Rows.Count).End(xlUp).Row
Sheets(2).Range("a" & lr + 1).Formula = "=now()"
Sheets(2).Range("b" & lr + 1) = "Booking"
Sheets(2).Range("c" & lr + 1) = "Start"
Sheets(2).Range("a" & lr + 1).Select
Selection.Copy
Sheets(2).Range("d" & lr + 1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub
You could also call out to the sheet by name with something like Sheets("DataSheet")
I am trying to compare cell A1 with B1 and if it is true populate cell F1 with the A1 value. But irrespective of my input values the if condition becomes true.
Sub Macro3()
Dim i As Integer
i = 1
For i = 1 To 10
If (Range("A" & i).Select = Range("B" & i).Select) Then
Range("A" & i).Select
Selection.Copy
Range("F" & i).Select
ActiveSheet.Paste
End If
Next i
End Sub
Instead of selecting, copying, and pasting, you can compare the Value property of the cells, then set the F column Value accordingly:
Dim i As Integer
For i = 1 To 10
If Range("A" & i).Value = Range("B" & i).Value Then
Range("F" & i).Value = Range("A" & i).Value
End If
Next
Consider this a compliment to Nick's answer (accept his if you find it to work, which you should). I wanted to help explain some of the things that are wrong in your code.
Before FIX:
Sub Macro3()
Dim i As Integer
i = 1
For i = 1 To 10
If (Range("A" & i).Select = Range("B" & i).Select) Then
Range("A" & i).Select
Selection.Copy
Range("F" & i).Select
ActiveSheet.Paste
End If
Next i
End Sub
AFTER FIX
Sub Macro4()
Dim i As Long
For i = 1 To 10
If Range("A" & i).Value = Range("B" & i).Value Then
Range("F" & i).Value = Range("A" & i).Value
End If
Next
End Sub
POINTS:
Use Long instead of Integer (small optimization since VBA will convert the int to a long anyway)
No need to declare i = 1 twice in a row
You should be comparing values, not simply selecting cells. There is rarely, if ever, a need to use the .Select keyword. You can access all object's properties directly.
Copy and paste is a heavy operation. Since you are in VBA, may as well just assign the value that is in A to the cell in column B. It's faster, and more effecient.
I hope this helps. BTW, you can simple enter:
=IF(A1=B1,A1,"")
in F1 and drag the formula down to get a similar result.
You can use a variant array to address your performance issue that you raise above. This code will run the same as Nicks except it will skip blanks cell, ie it will
update the F value if A and B are the same
skip updates if the A cell is blank
leave the existing F values in place if A<>B
It wasn't clear to me how you are comparing rows accross two sheets, can you expand on this?
Sub MyArray()
Dim X As Variant
Dim Y As Variant
Dim lngrow As Long
X = Range([a1], Cells(Rows.Count, "B").End(xlUp))
Y = Range([f1], [f1].Offset(UBound(X, 1) - 1, 0))
For lngrow = 1 To UBound(X, 1)
If Len(X(lngrow, 1)) > 0 Then
If X(lngrow, 1) = X(lngrow, 2) Then Y(lngrow, 1) = X(lngrow, 1)
End If
Next
Range([f1], [f1].Offset(UBound(X, 1) - 1, 0)) = Y
End Sub