In my excel table i have one row (5th row) as number of items and another (6th row) as the price of the items. For example i want to multiply 200 with $56.50 but I am having a problem with this script. Can anyone please help.
Sub calcprice()
Dim i As Integer
Dim iRowNumber As Integer ' Integer to store result in
Dim val As Double
iRowNumber = InputBox(Prompt:="Number of Rows", _
Title:="Rows: ", Default:="# of Rows")
For i = 1 To iRowNumber
If Cells(i, 5).Value >= 0 And Cells(i, 6).Value >= 0 And IsEmpty(Cells(i, 5)) = False And IsEmpty(Cells(i, 5)) = False Then
val = FormatCurrency(Cells(i, 5).Value) * Cells(i, 6).Value
Cells(i, 7).Value = val
End If
Next i
End Sub
it says runtime error 13
type mismatch
here is the image:
Here is the link: https://www.dropbox.com/s/lla2cuz8hqu5qyp/test.xlsm
also i cannot use the =a*b i have to use macros!
You don't need a loop
You can work with a single shot range in colunm G that
Adds a formula from G5 to the user entered iRowNumber to test whether a result > 0 happens in each row (or adds "" for a 0 result)
overwrite the formulae with the values
Sub calcprice()
Dim iRowNumber As Long ' Integer to store result in
iRowNumber = InputBox(Prompt:="Number of Rows", _
Title:="Rows: ", Default:="# of Rows")
With Range(Cells(5, 7), Cells(iRowNumber, 7))
.FormulaR1C1 = "=IF(N(RC[-1]*RC[-2]),RC[-1]*RC[-2],"""")"
.Value = .Value
End With
End Sub
Try this out. Remember to format the 5th cell and the 6th cell to the currency you like!
Sub calcprice()
Dim iRowNumber As Integer
Dim val As Double
iRowNumber = InputBox(Prompt:="Number of Rows", _
Title:="Rows: ", Default:="# of Rows")
For i = 1 To iRowNumber
If Cells(i, 5).Value >= 0 And Cells(i, 6) >= 0 Then
If Cells(i, 6).Value > 0 Then
val = Cells(i, 5).Value * FormatCurrency(Cells(i, 6).Value)
Cells(i, 7).Value = val
End If
End If
Next i
End Sub
You have For i = 1 to iRowNumber
The image shows that the data starts in row 5. The previous rows contain text.
Therefore, try For i = 5 to iRowNumber
Related
Hello is any sensible algorithm for transforming data table (Table A to Table B) ?
I trying to moving cells , but have no idea how to calculate a place where I should place additional row after my key field Name.
Table A origin
Name
Salary
Bonus
Amount
John S.
5000
Bonus A
50
John S.
Bonus B
100
Alex G.
7000
Bonus C
150
Alex G.
Bonus D
300
Table B (Expected outcome)
Name
Salary
Bonus
Amount
John S.
5000
John S.
Bonus A
50
John S.
Bonus B
100
Alex G.
7000
Alex G.
Bonus C
150
Alex G.
Bonus D
300
Sub TransformTable()
' Setting variables
Dim Name As String
Dim BaseSalary As String
Dim BonusName As String
Dim BonusAmount As Double
'Setting worksheet object
Dim SheetData As Worksheet
Set SheetData = Sheets("SheetData")
'counter for main loop
Dim x As Long
'Setting main object array
Dim MyArray As Variant
Dim Item As Integer
Item = 1
'reading values from table
MyArray = Worksheets("SheetData").ListObjects("Table1").DataBodyRange.Value
'counting last row value
'main loop
For x = LBound(MyArray) To UBound(MyArray)
'condition check how many costcenter ids with fixed value
lstRowSrs = SheetData.Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("SheetData").Cells(Item + 1, 13).Value = MyArray(x, 1)
Worksheets("SheetData").Cells(Item + 1, 14).Value = MyArray(x, 2)
If MyArray(x, 3) <> "" Then
' Cells(x, lstRowSrs).EntireRow.Insert
Worksheets("SheetData").Cells(Item + 2, 15).Value = MyArray(x, 3)
Worksheets("SheetData").Cells(Item + 2, 16).Value = MyArray(x, 4)
Item = Item + 1
Else
Worksheets("SheetData").Cells(Item + 1, 15).Value = MyArray(x, 3)
Worksheets("SheetData").Cells(Item + 1, 16).Value = MyArray(x, 4)
Item = Item + 1
End If
Next x
End Sub
You can obtain your desired output using Power Query, available in Windows Excel 2010+ and Office 365 Excel
Select some cell in your original table
Data => Get&Transform => From Table/Range
When the PQ UI opens, navigate to Home => Advanced Editor
Make note of the Table Name in Line 2 of the code.
Replace the existing code with the M-Code below
Change the table name in line 2 of the pasted code to your "real" table name
Examine any comments, and also the Applied Steps window, to better understand the algorithm and steps
The basic algorithm:
Unpivot the Salary and Amount columns which puts them all into a single column
the Bonus column will have some duplicates -- remove them if the Attribute column contains "Salary"
Remove the contents of the Salary column; rename and reorder the columns
M Code
let
//change table name in next line to actual name in your workbook
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
//set the data types
#"Changed Type" = Table.TransformColumnTypes(Source,{
{"Name", type text}, {"Salary", Int64.Type}, {"Bonus", type text}, {"Amount", Int64.Type}}),
//Unpivot the columns other than Name and Bonus
#"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Name", "Bonus"}, "Attribute", "Value"),
//blank the "bonus" if attribute=salary
#"Replace Bonus with null" = Table.ReplaceValue(#"Unpivoted Other Columns",
each [Bonus],
each if [Attribute]="Salary" then null else [Bonus],
Replacer.ReplaceValue,{"Bonus"}),
//set columns in correct order
#"Reordered Columns" = Table.ReorderColumns(#"Replace Bonus with null",{"Name", "Attribute", "Bonus", "Value"}),
//rename "Attribute"=>"Salary" and blank the contents
Rename = Table.RenameColumns(#"Reordered Columns",{{"Attribute","Salary"},{"Value","Amount"}}),
blankIt = Table.ReplaceValue(Rename, each [Salary],null, Replacer.ReplaceValue,{"Salary"})
in
blankIt
Here's another way. It has the same results as #Sgdva but uses some slightly different techniques. Not better, just something to consider.
Sub TransformTable()
Dim vaValues As Variant
Dim i As Long
Dim aOutput() As Variant
Dim lCnt As Long
'put all the values in a 2-d array
vaValues = Sheet1.ListObjects(1).DataBodyRange
'make your output array - double the rows of the input
'it will be too many rows, but you won't run out of room
ReDim aOutput(1 To UBound(vaValues, 1) * 2, 1 To 4)
'Loop through the 2-d array
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
If Len(vaValues(i, 2)) > 0 Then 'a salary exists
'add a row to the output array
lCnt = lCnt + 1
aOutput(lCnt, 1) = vaValues(i, 1)
aOutput(lCnt, 4) = vaValues(i, 2)
End If
If Len(vaValues(i, 4)) > 0 Then 'a bonus exists
'add a row to the output array
lCnt = lCnt + 1
aOutput(lCnt, 1) = vaValues(i, 1)
aOutput(lCnt, 3) = vaValues(i, 3)
aOutput(lCnt, 4) = vaValues(i, 4)
End If
Next i
'write out the output array in one shot
Sheet1.Range("G1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
Solution
I changed the logic that you posted as follows
Identify the rows to be added
Insert them at once (to save memory instead of inserting one by one)
Append the data needed by looping again in the rows
For demonstration purposes, I limited the logic to the active sheet and with the data sample shown.
Demo
Code
Sub Exec_DivideSalary()
Dim CounterRow As Long
Dim RangeRowsToAdd As Range
For CounterRow = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(CounterRow, 2).Value <> "" Then ' 1. If Cells(CounterRow, 2).Value <> ""
If RangeRowsToAdd Is Nothing Then ' 2. If RangeRowsToAdd Is Nothing
Set RangeRowsToAdd = Rows(CounterRow + 1)
Else ' 2. If RangeRowsToAdd Is Nothing
Set RangeRowsToAdd = Union(RangeRowsToAdd, Rows(CounterRow + 1))
End If ' 2. If RangeRowsToAdd Is Nothing
End If ' 1. If Cells(CounterRow, 2).Value <> ""
Next CounterRow
RangeRowsToAdd.Insert Shift:=xlDown
For CounterRow = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(CounterRow, 2).Value <> "" Then ' 3. If Cells(CounterRow, 2).Value <> ""
Cells(CounterRow + 1, 1).Value = Cells(CounterRow, 1).Value: Cells(CounterRow + 1, 3).Value = Cells(CounterRow, 3).Value: Cells(CounterRow + 1, 4).Value = Cells(CounterRow, 4).Value
Cells(CounterRow, 4).Value = Cells(CounterRow, 2).Value
Cells(CounterRow, 2).Value = "": Cells(CounterRow, 3).Value = ""
End If ' 3. If Cells(CounterRow, 2).Value <> ""
Next CounterRow
End Sub
I have table in Sheet1. I can sum up all numeric data of a certain Country.
However I wanted only to sum-up to numbers with the same date.
I have ComboBox for the date. So for example If I choose July 1, it will only add those numbers in July 1.
My desired result if I choose July 1 is the following:
America 24
Brazil 56
Canada 68
screenshot
My code:
Private Sub ComboBox1_Change()
Dim a As Long
Dim b As Long
Dim c As Long
Dim lastrow As Long
a = 0
b = 0
c = 0
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, 3) = "America" Then
a = Cells(i, 4) + a
ElseIf Cells(i, 3) = "Brazil" Then
b = Cells(i, 4) + b
ElseIf Cells(i, 3) = "Canada" Then
c = Cells(i, 4) + c
End If
Next i
'Range("A16") = a
txtAmerica.Value = a
txtBrazil.Value = b
txtCanada.Value = c
End Sub
Private Sub UserForm_Initialize()
ComboBox1.List = Sheets("Sheet1").Range("G1:G10").Value
End Sub
Assuming the values in column A are dates, and also assuming your locale is using a mm/dd/yyyy date format, this is as simple as just wrapping your summation code in an If statement that checks the date:
For i = 2 To lastrow
If Cells(i, "A").Value = CDate(ComboBox1.Value) Then
If Cells(i, 3) = "America" Then
a = Cells(i, 4) + a
ElseIf Cells(i, 3) = "Brazil" Then
b = Cells(i, 4) + b
ElseIf Cells(i, 3) = "Canada" Then
c = Cells(i, 4) + c
End If
End If
Next i
I have a small range of cells, C6:C10. I'm trying to apply an if statement to this range of cells using VBA code. Currently, my code takes the output of the if statement for the first cell (C6), and replicates that value for cells C7:C10. The if statement is correct, I'm just not sure how to apply it to a range of cells in a column.
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = ActiveCell(6, 3).Value
For i = 6 To 10
If Right(Left(Segment, 6), 1) = "/" Then
ActiveCell(i, 3).Value = Left(Segment, 5)
Else
ActiveCell(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
It should be fine if you use Cells instead of ActiveCell, except that you'll have to change your loop to go from 7 to 10 or else it will over-write the original cell as well as C7:C10.
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = Cells(6, 3).Value
For i = 7 To 10
If Right(Left(Segment, 6), 1) = "/" Then
Cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = Cells(i, 3).Value
For i = 7 To 10
If Right(Left(Segment, 6), 1) = "/" Then
cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
here three (out of many other) possible codes, in simplicity order (the last being more simple than the first):
Option Explicit
Sub Cleanup()
Dim Segment As String
Dim i As Integer
For i = 6 To 10
Segment = Cells(i, 3).Value '<== Cells(i, 3) is the current cell as per the current row (i)
If Mid(Segment, 6, 1) = "/" Then
Cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
Sub Cleanup2()
Dim i As Integer
For i = 6 To 10
With Cells(i, 3) 'avoid repetitions (and a variable, too) by using 'With' keyword and implying 'Cells(i, 3)' preceeds every dot (".") till next 'End With" statement
If Right(Left(.Value, 6), 1) = "/" Then
.Value = Left(.Value, 5)
Else
.Value = Left(.Value, 6)
End If
End With
Next i
End Sub
Sub Cleanup3()
Dim i As Integer
For i = 6 To 10
With Cells(i, 3)
.Value = Left(.Value, IIf(Mid(.Value, 6, 1) = "/", 5, 6)) ' use Iif function to avoid multiple lines. Also use 'Mid' function in lieu of 'Right(Left(..))'
End With
Next i
End Sub
I want to refer a column by its header name.
Currently column is 4th one and header name is "Preference".
And the column consists of "Yes" or "No"
5th column header is "Reason"
And it is filled only when "Preference" column is "No"
My code is
Private Sub CommandButton1_Click()
Dim i As Integer
Dim MyWorksheetLastRow As Byte
Dim MyWorksheetLastColumn As Byte
MyWorksheetLastRow = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
MyWorksheetLastColumn = Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets(1).Cells(1, MyWorksheetLastColumn + 1).Value = "Result"
For i = 2 To MyWorksheetLastRow
If Cells(i, 4).Value = "Yes" Then
Cells(i, MyWorksheetLastColumn + 1).Value = Cells(i, 4).Value
Else: Cells(i, MyWorksheetLastColumn + 1).Value = Cells(i, 5).Value
End If
Next i
End Sub
What I want is instead of Cells(i,4) , I want to call the it by column header example: Cells(i,"Preference").
Because I won't the column number of "Preference" in prior. And I use excel vba because I have to deal 20-30 similar files.
Further to my comments, if you want to do it direct, you would have to do this:
cells(i,Application.WorksheetFunction.Match("Preference", Range("1:1"), 0)).
Here is a function to find the column for X instance. I have put a subroutine in there to call it as an example for you.
Sub ColInstanceExample()
Dim MyColInstance As Long
MyColInstance = ColInstance("Preference", 2) 'Pass in what you are searching for and the instance you want to return the column number for
If MyColInstance = 0 Then
MsgBox "Not Found"
Else
MsgBox "Found at column: " & MyColInstance
End If
End Sub
Function ColInstance(HeadingString As String, InstanceNum As Long)
Dim ColNum As Long
On Error Resume Next
ColNum = 0
For X = 1 To InstanceNum
ColNum = (Range("A1").Offset(0, ColNum).column) + Application.WorksheetFunction.Match(HeadingString, Range("A1").Offset(0, ColNum + 1).Resize(1, Columns.Count - (ColNum + 1)), 0)
Next
ColInstance = ColNum
End Function
I've currently got the code below. There can only currently be seven values for "ins" and so the code suffices, however as of next month I have been told that there will be over 900 values!
I assume that rather than writing another 900 case statements I could use an array of some sort. Can anyone give me a nudge in the right direction?
Private Sub test()
Dim i As Long
Dim lr As Long
Dim ins As String
lr = Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To lr
Select Case Cells(i, 20)
Case Is = ""
ins = Mid(Cells(i, 11), 14, 2)
Select Case Cells(i, 10)
Case "Inx", "ComInx"
Select Case Cells(i, 9)
Case "EINX"
Select Case ins
Case "LD"
Cells(i, 9).Value = "SR"
Case "GP"
Cells(i, 9).Value = "GAMA"
Case "AV"
Cells(i, 9).Value = "NU"
Case "AX"
Cells(i, 9).Value = "AXC"
Case "MZ"
Cells(i, 9).Value = "MZE"
Case "AD"
Cells(i, 9).Value = "AGD"
Case "AG"
Cells(i, 9).Value = "AG"
End Select
End Select
End Select
End Select
Next
End Sub
I would use a dictionary object for this. Here is a proof-of-concept based on your lines:
Private Sub test()
Dim i As Long
Dim lr As Long
Dim ins As String
Dim rngCases As Range, rngCases2 As Range, rngCase As Range
Dim dicCases As Dictionary
lr = Range("A" & Rows.Count).End(xlUp).Row
' rngCases stores the possible values of ins
' Here I assume they are stored in col 40
Set rngCases = Range(Cells(6, 40), Cells(lr, 40))
' rngCases2 stores the values you want to map for each value of ins.
' Here I assume they are stored in col 41
' No of entries = No of entries of rngCases
Set rngCases2 = Range(Cells(6, 41), Cells(lr, 41))
Set dicCases = New Dictionary
For Each rngCase In rngCases
If Not dicCases.Exists(rngCase.Value) Then
dicCases.Add Key:=rngCase.Value, Item:=rngCases2.Value
End If
Next rngCase
For i = 6 To lr
Select Case Cells(i, 20)
Case Is = ""
ins = Mid(Cells(i, 11), 14, 2)
Select Case Cells(i, 10)
Case "Inx", "ComInx"
Select Case Cells(i, 9)
Case "EINX"
' We simply need to refer to the mapped value of ins
If dicCases.Exists(ins) then
Cells(i, 9) = dicCases.Item(ins)
Else
' Throw an error or do something here
End If
End Select
End Select
End Select
Next
End Sub
To enable the Dictionary, go to Tools->References and select Microsoft Scripting Runtime.
I hope this gets you started!