How can I do a Calculation in Microsoft Excel VBA? - excel

I'm 15 and I'm doing a Internship as a Developer and I've got a kinda hard exercise.
I have a Table with 3 columns, A is "Number" B is "percent" and C is "Value". The column "value" is blank and I Need to calculate the value with a macro button. I've tried this, but it was wrong because I didn´t calculate it in VBA:
Public Sub PushButton ()
Range("C2:C11").Formula = "=A2*B2/100"
Range("C2:C11").Value = Range("C1:C6).Value
End Sub
How do I solve this?

You are using a defined range, you could do it with a dynamic range like this:
Option Explicit
Sub PushButton()
Dim i As Long, LastRow As Long
With ThisWorkbook.ActiveSheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'first you need to find the last row on the active sheet
For i = 2 To LastRow 'then iterate through all the rows starting from 2, if row 1 has headers
.Cells(i, 3) = .Cells(i, 1) * .Cells(i, 2) / 100
Next i
End With
End Sub
If you need help understanding this code, let me know.
Edit: Explanation
Well, the first thing you must do is Dimension all your variables, and to help that you can use the Option Explicitright above all your code.
I've dimensioned 1 variable for the loop and another one to find the last row with text.
To find the last row what you are actually doing is going to excel, select the last row (1048576) and the column where it will have text, in this case 1 or column "A" and then pushing ctrl+Up excel and vba will get you to the last cell with text.
To do that you use Cells(Row, column) instead of manually inserting row 1048576 you can just use rows.count and it will be the same.
Once you get the last row you just iterate with a For iloop meaning For a variable called i which equals 2 (For i = 2) To LastRow (to the last row you calculated) VBA will repeat the code in between the ForAnd Next adding 1 number to i everytime the loop restarts.
In this case is just adding a number to the rows on Cells(i, 3) so you can modify that cell depending of its i value.

I think you need to question why Excel needs to calculate on demand rather than automatically like normal. Failing that there are a few options
You could change your calculation method to Manual using the following in the ThisWorkbook object
Option Explicit
Dim xlCalcMethod As XlCalculation
Private Sub Workbook_Open()
With Application
' Store users current method for when closing the workbook
xlCalcMethod = .Calculation
.Calculation = xlCalculationManual
End With
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Reset calculation
Application.Calculation = xlCalcMethod
End Sub
and then when the button is pressed use the following code to calculate placed in a Module
Option Explicit
Public Sub Button_Click()
Application.Calculate
End Sub
Another option to do this without looping would be:
Sub CalculateRange()
Dim rng As Range
' Update for your Range
With ActiveSheet
Set rng = .Range("C2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With
rng.Value2 = Evaluate(rng.Offset(0, -2).Address & "*" & rng.Offset(0, -1).Address & "/100")
End Sub
Finally, the way you've come up with is perfectly acceptable as VBA

Related

How To Combine <> and X variable in Excel VBA?

I am working on excel VBA and I want all rows that does not equal to my cell value/reference (Cell E5) to be deleted but what is happening right, it deletes all rows in that sheet.
Sub DeleteNotEqualTo()
Dim ws As Worksheet
x = Range("E5").Value
Set ws = ThisWorkbook.Worksheets("Conso")
ws.Range("B8:Z5000").AutoFilter Field:=11, Criteria1:="<> & x"
Application.DisplayAlerts = False
ws.Range("B9:Z5000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error Resume Next 'Clear Filter
ws.ShowAllData
On Error GoTo 0
End Sub
I'm assuming that you're setting the reference value in cell E5 (row 5) and starting from row 8 ("B8:Z5000") you crosscheck if for each record field 11 corresponds to that specific value.
I don't recommend this approach because:
when manipulating spreadsheets, you shouldn't use the auto filter. The auto filter is rather designed for visibility when you look at a spreadsheet - not for a programmatic approach. You should be aware that, even if data is filtered out of the visible range, if you'd loop through the records, the program would still take the non visible records into consideration.
by setting a static range, you are always going to be limited by the number of rows you set. You can easily use a dynamic range instead, like that your script will always crosscheck all rows that are not empty.
Option Explicit
'always recommend to use this option, it forces you to
'declare the type of every single variable
Sub DeleteNotEqualTo()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Conso")
Dim x As String 'declaring string variable, you may have to adapt
'x = Range("E5").Value you could also with the cells object, check next line
x = ws.Cells(5, 5).Value '5,5 = row 5, column 5
'now comes the loop
'you have to declare a so called iterator variable to loop, in this case "i"
'the iterator drives the loop through the records
'you also need a variable that determines the last row to be checked
'in this case you define this by checking the so called "UsedRange"
'the "UsedRange" counts from the first row that contains to the last
'check out the indicated link for more info regarding finding the last row
Dim i As Integer 'iterator variable
Dim lrow As Integer 'variable for the last row
lrow = ws.UsedRange.Rows.Count + 4 'assuming that row 5 is the first to contain a value
'now loop through the records
'here I'm assuming field 11 of your auto filter correspond to column 11 in the sheet
'important sidenote: as you're deleting rows, you have to loop bottom up
'if you loop top to bottom, the loop may skip rows that shift up
For i = lrow To 8 Step -1 'assuming that the first row to be checked is row 8
If ws.Cells(i, 11).Value = x Then
ws.Cells(i, 11).EntireRow.Delete
End If
Next i
End Sub
Here's a link with more info regarding finding the last row in a spreadsheet. Very helpful with dynamic ranges:
https://www.automateexcel.com/vba/find-last-row-column-cell/
What worked for me in your workbook is changing this line:
ws.Range("B8:Z5000").AutoFilter Field:=11, Criteria1:="<> & x"
to:
ws.Range("B8:Z5000").AutoFilter Field:=11, Criteria1:="<>*" & x & "*"
The presence of * wildcard changes the criteria from an exact match to a partial match. (This shouldn't have been necessary, but specifying an exact match didn't filter the range correctly for reasons I'm unsure of.)
Option Explicit
Private Sub DeleteNotEqualTo()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Conso")
Dim x As Variant
x = Range("E5").Value
ws.Range("B8:Z5000").AutoFilter Field:=11, Criteria1:="<>*" & x & "*"
Application.DisplayAlerts = False
ws.Range("B9:Z5000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error Resume Next 'Clear Filter
ws.ShowAllData
On Error GoTo 0
End Sub

Move to next row to browse it in the Integrated Web Browser

Hy, I am using Microsoft Excel as an Integrated Google Map. It working fine for one row. Here is its code.
Private Sub CommandButton1_Click()
WebBrowser1.Navigate ActiveSheet.Range("D2").Value
End Sub
Basically what i want, I want when I click on the Next Map, the row 3 shold be populate in the map. It works fine for one record at a time and only for D2. But I want when I move "Next Map" button it should work for D3 and other as like for D2.
I am using below code but it does not work.
Sub SelectC()
Dim x As Variant
x = Cells(ActiveCell.Row, "D").Offset(1).Select
WebBrowser1.Navigate ActiveSheet.Range.Selection.Value
End Sub
It gives an error as under.
Please guide me where I am writing wrong code. thanks
I would do this slightly different. I would completely avoid the use of Activecell/Selection etc. You may want to see How to avoid using Select in Excel VBA
I will use 1 cell to store the current row number and use that. Here is an example. I am going to use say Cell D1 and make its font white so that it will not show. For demonstration purpose, I am not making it white. Change it to whatever you want. You have asked for NEXT button. I am also including a code which you can use for PREVIOUS.
See this example
Option Explicit
Dim ws As Worksheet
Dim lRow As Long
Dim NextRow As Long
Sub NextMap()
'~~> Set this to the relevant worksheet
Set ws = Sheet1
With ws
'~~> Get last row of the Col D
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
'~~> Get the next row
NextRow = .Range("D1").Value2 + 1
'~~> Check if it is greater than last row
If NextRow > lRow Then
MsgBox "End of data reached"
Else
'WebBrowser1.Navigate .Range("D" & NextRow).Value2
'~~> Store the row number in D1
.Range("D1").Value = .Range("D1").Value + 1
End If
End With
End Sub
Sub PreviousMap()
Set ws = Sheet1
With ws
NextRow = .Range("D1").Value2 - 1
If NextRow < 2 Then
MsgBox "Begining of data reached"
Else
'WebBrowser1.Navigate .Range("D" & NextRow).Value2
.Range("D1").Value = .Range("D1").Value - 1
End If
End With
End Sub
In ACTION
Minimally, the code WebBrowser1.Navigate ActiveSheet.Range.Selection.Value should be changed to something along the lines of WebBrowser1.Navigate ActiveCell.Value. The syntax you originally used is poorly formed.

For Loop Copy and Paste Excel VBA

Function Iterate()
Dim i As Integer
For i = 1 To 10
Worksheets("Calculator").Calculate
Worksheets("Calculator").Range("AC6:AC16").Copy Destination:=Sheets("Iterations").Range("A1:A10")
Worksheets("Calculator").Range("AT10:AT11").Copy Destination:=Sheets("Iterationas").Range("A11:A12")
Worksheets("Iterations").Paste
Next
End Function
My Goal, is to run this loop as many times as I'll need, and after every single loop, I want excel to take the Range("cells") and copy them to the "Iterations" worksheet.
The data on Calculator is refreshed every loop, so new calculations appear. Once the new calculations appear, I want to paste it one next to the other (which I don't know how to do).
For now, this gives me a runtime error Subscript it out of range
Any advice?
I have tried the following:
Option Explicit
Public Sub Iterate()
Dim i As Long
For i = 1 To 10
Worksheets(1).Calculate
Worksheets(1).Range("AC6:AC16").Copy Destination:=Worksheets(2).Range("A1:A10")
Worksheets(1).Range("AT10:AT11").Copy Destination:=Worksheets(2).Range("A11:A12")
Next
End Sub
It works, just make sure that you rename the Worksheets(1) and (2) relevantly. In general, use Function, when you expect a value to be returned. For changes in a worksheet, use Sub.
In general, what you wanted in the comments is to copy the values and to put them next to each other column. Here is how to get it:
Option Explicit
Public Sub Iterate()
Dim i As Long
For i = 1 To 10
With Worksheets(1)
Worksheets(2).Calculate
Worksheets(2).Range("AC6:AC16").Copy
.Cells(1, i).PasteSpecial Paste:=xlPasteValues
Worksheets(2).Range("AT10:AT11").Copy
.Cells(1, i + 10).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
Next
End Sub

Copy Check Box to Every 5th Cell with Command Button

I have an issue which i can't solve.I wrote this code:
Private Sub CommandButton2_Click()
Sheets("sheet2").OLEObjects("CheckBox1").Copy
Sheets("sheet3").Range("V7").PasteSpecial
End Sub
This code copy a checkbox from (sheet 2) to (sheet 3) starting from V7 cell. Now I want the next time I press the command button to paste the data to cell V12,next time to V17 etc. My vba knowledge is not very good as you can see.
This code will see how many checkboxes are already in the sheet you are pasting to and add 5 rows for each check box, then paste five rows under the last one.
Private Sub CommandButton2_Click()
' copy checkbox
Sheets("sheet2").OLEObjects("CheckBox1").Copy
Dim wks As Worksheet
Set wks = Sheets("Sheet3")
Dim cb As OLEObject, i As Integer
'determine how many boxes are already there and get count of cell to paste to
i = 7
For Each cb In wks.OLEObjects
If InStr(1, cb.Name, "CheckBox") Then i = i + 5
Next
'paste new checkbox
Sheets("sheet3").Range("V" & i).PasteSpecial
End Sub
Use a global variable. These must be at the top of your sheet, module, or form code above all subs and functions.
Then use that as the row number in your range. Range("V" & lRow)
Private lRow As Long
Private Sub CommandButton2_Click()
'Let's check if this is the first time the button has been used.
If lRow = 0 then
lRow = 7
Else
'Increment the row from the one we wrote to last time.
lRow = lRow + 5
End If
'Do the copy
Sheets("sheet2").OLEObjects("CheckBox1").Copy
Sheets("sheet3").Range("V" & lRow).PasteSpecial
End Sub
I dont know what data you got between in Sheet(3).Range("V7") and Sheet(3).Range("V12")
but juste before you're PasteSpecial, you shoud keep track where was the last time you paste data in Sheets("sheets3") in a specific cell in Sheet("sheets3"), in exemple : Sheets("Sheet3").Range("A1")
Then you'll be able to pastespecial to this cell 5 row under like this :
Sheets("sheet3").Range(Sheets("Sheets3").Range("A1").Offset(5,0)).PasteSpecial
right after that you update the Sheets("Sheets3").Range("A1") = Sheets("sheet3").Range(Sheets("Sheets3").Range("A1").Offset(5,0)).Address
So this should do the work :
Private Sub CommandButton2_Click()
Dim oWsSource as Worksheet
Dim oWsDestination as Worksheet
Set oWsDestination = ThisWorkbook.Worksheet("Sheets3")
Set oWsSource = ThisWorkbook.Worksheet("Sheets2")
'Do the copy
oWsSource.OLEObjects("CheckBox1").Copy
oWsDestination.Range(oWsDestination.Range("A1").Value).Offset(5,0)).PasteSpecial
oWsDestination.Range("A1").Value = oWsDestination.Range(oWsDestination.Range("A1").Value).Offset(5, 0)).Address
End Sub
All the answers put the first checkbox but the next one put it again to the same cell as before.I don't know if its matter but I use excel 2010.

Matching two data lists in Excel VBA and exporting to New Sheet

I receive an excel file monthly and have to export parts of it to a new file. I have a list of identifier numbers and I am trying to match the list of numbers in the selected list to the full file and then export the rows of relevant data to a new sheet.
Sub Run_All_Macros()
Application.ScreenUpdating = False
Sheets.Add.Name = "Output"
Call Convert_to_Numbers
Call Highlight_Selected_Contractors
End Sub
'Original Spreadsheet is formatted incorrectly
'Convert PSD Codes to Numbers
Sub Convert_to_Numbers()
Dim xCell As Range
Range("A2:A2500").Select
For Each xCell In Selection
xCell.Value = CDec(xCell.Value)
Next xCell
End Sub
'Highlight Selected Contractors
Sub Highlight_Selected_Contractors()
Dim Full, Selection, Code, SelectedCode As Range
Worksheets("Sheet1").Select
'Set all cells in Column A Sheet 1 to Full
Set Full = Worksheets("Sheet1").Range("A1", Range("A1").End(xlDown))
'Set all cells in Column A Sheet 2 to Selection
Worksheets("Sheet2").Select
Set Selection = Worksheets("Sheet2").Range("A1", Range("A1").End(xlDown))
'If the numbers match highlight the cell
For Each Code In Full
For Each SelectedCode In Selection
If Code.Value = SelectedCode.Value Then
*** Code.Select
Selection.Copy
Sheets.Select ("Output")
ActiveSheet.Paste
End If
Next SelectedCode
Next Code
End Sub
After executing this code column A in 'Output' is filled with zeros from A2:A2500. From messing around with breakpoints I've identified the problem to be where I've placed * but I'm not sure what's wrong with what's written there.
Thanks
There few errors in the code above and I also have few suggestions and finally the code.
ERRORS
1) Sheets.Add.Name = "Output" This line will give you an error if there is already a sheet called "Ouput". Delete the sheet first and then create it. You must be wondering that in case the sheet is not there, then how can I delete it? For such scenarios you can use On Error Resume Next which should be avoided in most cases.
2) When working with ranges, always specify which sheet you are referring to else Excel will always assume that you are referring to the "ActiveSheet". As you realized that Sub Convert_to_Numbers() was taking Output Sheet into consideration whereas you want the operation to happen in "Output" Sheet.
3) Dim Full, Selection, Code, SelectedCode As Range As mentioned in my comments earlier avoid using Excel Reserved words as variables. Also unlike VB.Net, if you declare variables as you did in VBA then only the last variable will be declared as Range. The other 3 will be declared as variant. VB defaults the variable to being type Variant. A Variant type variable can hold any kind of data from strings, to integers, to long integers, to dates, to currency etc. By default “Variants” are the “slowest” type of variables. Variants should also be avoided as they are responsible for causing possible “Type Mismatch Errors”. It’s not that we should never use Variants. They should only be used if you are unsure what they might hold on code execution.
4) Avoid the use of words like .ActiveCell, Selection, Select, Activate etc. They are a major cause of errors. Also they slow your code down.
SUGGESTIONS
1) Instead to using Sheets("WhatEver") every time, store it in a variable and then use that variable. Will cut down your code.
2) Indent your code :) it's much easier to read
3) Group tasks together. For example if you have to do with something with a particular sheet then keep it together. It is easier to read and amend if required.
4) Instead of hard coding your values, get actual ranges. Range("A2:A2500") is a classic example. Will you always have data till 2500? What if it is less or more?
5) End(xlDown) will never give you the last row if there is a blank cell in between. To get the last row in a column, say A in "Sheet1", use this
Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row`
6) Instead of looping, you can use the WorksheetFunction CountIf(). Loops should be avoided as much as possible as they slow down your code.
7) Use appropriate Error handling.
8) Comment your code. It's much easier to know what a particular code or section is doing.
CODE
Option Explicit
Sub Run_All_Macros()
Dim ws1I As Worksheet, ws2I As Worksheet, wsO As Worksheet
Dim ws1LRow As Long, ws2LRow As Long, wsOLr As Long
Dim xCell As Range, rFull As Range, rSelection As Range
Dim rCode As Range, rSelectedCode As Range
On Error GoTo Whoa '<~~ Error Handling
Application.ScreenUpdating = False
'~~> Creating the Output Sheet
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Output").Delete
On Error GoTo 0
Sheets.Add.Name = "Output"
Application.DisplayAlerts = True
'~~> Working with 1st Input Sheet
Set ws1I = Sheets("Sheet1")
With ws1I
'~~> Get Last Row of Col A
ws1LRow = .Range("A" & Rows.Count).End(xlUp).Row
'~~> Set the range we want to work with
Set rFull = .Range("A1:A" & ws1LRow)
'~~> The following is not required unless you want to just format the sheet
'~~> This will have no impact on the comparision. If you want you can
'~~> uncomment it
'For Each xCell In .Range("A2:A" & ws1LRow)
'xCell.Value = CDec(xCell.Value)
'Next xCell
End With
'~~> Working with 2nd Input Sheet
Set ws2I = Sheets("Sheet2") '<~~ Input Sheet 2
ws2LRow = ws2I.Range("A" & Rows.Count).End(xlUp).Row
Set rSelection = ws2I.Range("A1:A" & ws2LRow)
'~~> Working with Output Sheet
Set wsO = Sheets("Output")
wsO.Range("A1") = "Common values"
wsOLr = wsO.Range("A" & Rows.Count).End(xlUp).Row + 1
'~~> Comparison : If the numbers match copy them to Output Sheet
For Each rCode In rFull
If Application.WorksheetFunction.CountIf(rSelection, rCode.Value) > 0 Then
rCode.Copy wsO.Range("A" & wsOLr)
wsOLr = wsOLr + 1
End If
Next rCode
MsgBox "Done"
LetsContinue:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Let me know if you still get any errors :)
HTH

Resources