Excel VBA: What is the best way to sum a column in a dataset with variable amounts of lines? - excel

I need to sum two columns (B and C) in a dataset. The number of rows with data will vary between 1 and 17. I need to add the sums two rows beneath the last row of data (end result example in image 1).
My code worked beautifully for one dataset, but I am getting an error
Run-time error'6': Overflow
for a different dataset. What am I doing wrong?
'Units total
Windows("Final_Files.xlsb").Activate
Sheets("Revenue Summary").Select
lastrow = Worksheets("Revenue Summary").Cells(Rows.Count, 2).End(xlUp).Row
Dim a As Integer
a = 10000
For i = lastrow To 2 Step by - 1
a = a + Worksheets("Revenue Summary").Cells(i, 2).Value
Next
Worksheets("Revenue Summary").Cells(lastrow + 2, 2).Value = a
Correct End Result

You can try below sub-
Sub SumBC()
Dim sh As Worksheet
Dim lRowB As Long, lRowC As Long
Dim bSum As Double, cSum As Double
Windows("Final_Files.xlsb").Activate
Set sh = Worksheets("Revenue Summary")
lRowB = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row
lRowC = sh.Cells(sh.Rows.Count, 3).End(xlUp).Row
bSum = WorksheetFunction.Sum(sh.Range("B2:B" & lRowB))
cSum = WorksheetFunction.Sum(sh.Range("C2:C" & lRowC))
sh.Cells(lRowB + 2, 2) = bSum
sh.Cells(lRowC + 2, 3) = cSum
sh.Activate
Set sh = Nothing
End Sub
Remember: If you want to run same sub multiple time then you need clear totals otherwise it will add totals again again below of last totals.

Your code is perfect but there is only one error. You have initialized variable 'a' with 10000. Change it to 0.
a = 0
then your code will be perfect.

Add Totals to Multiple Columns
If you're not OP: It is easy to test the code. Open a new workbook and insert a module. Copy the code into the module. Uncomment the Sheet1 line, and outcomment the Revenue Summary line. In worksheet Sheet1 add some numbers in columns 2 and 3 and your ready.
Run only the insertTotals procedure. The calculateSumOfRange is called when needed.
Play with the constants in insertTotals and change the values in the columns. Add text, error values, booleans to see how the code doesn't break.
The issue with Application.Sum or WorksheetFunction.Sum is that it fails when there are error values in the range. That's what the calculateSumOfRange is preventing. If there is an error value, the loop approach is used. If not, then Application.Sum is the result.
You can use the calculateSumOfRange in Excel as a UDF. Just don't include the cell where the formula is and you're OK, e.g. =calculateSumOfRange(A1:B10).
The Code
Option Explicit
Sub insertTotals()
Const FirstRow As Long = 2 ' First Row of Data
Const LastRowCol As Long = 2 ' The column where the Last Row is calculated.
Const TotalsOffset As Long = 2 ' 2 means: 'data - one empty row - totals'
Dim Cols As Variant
Cols = Array(2, 3) ' add more
'With ThisWorkbook.Worksheets("Sheet1")
With Workbooks("Final_Files.xlsb").Worksheets("Revenue Summary")
' Define Last Row ('LastRow') in Last Row Column ('LastRowCol').
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, LastRowCol).End(xlUp).Row
' Define Last Row Column Range ('rng').
Dim rng As Range
Set rng = .Range(.Cells(FirstRow, LastRowCol), _
.Cells(LastRow, LastRowCol))
Dim j As Long
' Validate Columns Array ('Cols').
If LBound(Cols) <= UBound(Cols) Then
' Iterate columns in Columns Array.
For j = LBound(Cols) To UBound(Cols)
' Use 'Offset' to define the current Column Range and write
' its calculated total below it.
.Cells(LastRow + TotalsOffset, Cols(j)).Value = _
calculateSumOfRange(rng.Offset(, Cols(j) - LastRowCol))
Next j
End If
End With
End Sub
Function calculateSumOfRange(SourceRange As Range) _
As Double
' Initialize error handling.
Const ProcName As String = "calculateSumOfRange"
On Error GoTo clearError ' Turn on error trapping.
' Validate Source Range.
If SourceRange Is Nothing Then
GoTo NoRange
End If
' Calculate Sum of Range.
Dim CurrentValue As Variant
CurrentValue = Application.Sum(SourceRange)
Dim Result As Double
If Not IsError(CurrentValue) Then
Result = CurrentValue
Else
Dim Data As Variant
If SourceRange.Rows.Count > 1 Or SourceRange.Columns.Count > 1 Then
Data = SourceRange.Value
Else
ReDim Data(1, 1)
Data(1, 1) = SourceRange.Value
End If
Dim i As Long
Dim j As Long
For i = 1 To UBound(Data, 1)
For j = 1 To UBound(Data, 2)
CurrentValue = Data(i, j)
If IsNumeric(CurrentValue) And _
Not VarType(CurrentValue) = vbBoolean Then
Result = Result + CurrentValue
End If
Next j
Next i
End If
' Write result and exit.
calculateSumOfRange = Result
GoTo ProcExit
' Labels
NoRange:
Debug.Print "'" & ProcName & "': No range (Nothing)."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
ProcExit:
End Function

The following code summs up all the rows under "B2" and "C2". Adapt it to your needs.
' Keep a reference to the worksheet
Dim ws as Worksheet
Set ws = Worksheets("Revenue Summary")
' This is how many rows there are.
Dim rowCount as Long
rowCount = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row-1
' This is the summation operation over each column
Dim b as Double, c as Double
b = WorksheerFunction.Sum(ws.Range("B2").Resize(rowCount,1))
c = WorksheerFunction.Sum(ws.Range("C2").Resize(rowCount,1))
' This writes the sum two cells under the last row.
ws.Range("B2").Cells(rowCount+2,1).Value = b
ws.Range("C2").Cells(rowCount+2,1).Value = c

Related

VBA: faster way to change row (or cell) color based on values without referring to cell

Is there in VBA faster way to change row (or cell) color based on values without referring to cell
Referring to cell each time inside loop is very slow, that's why i am looking for faster method doing it in VBA.
Table:
Amount1
Amount2
100
50
20
200
...
...
If Amount1 is greater than Amount2, entire row(or cell) is red, vice versa entire row(or cell) is green.
Thank You!
It would have been helpful if you had clarified why you can't use CF as suggested, but if you really can't when looping it's best to refer to directly to cells as little as possible, especially changing values or formats. Try something like this:
Sub SampleValues()
Dim bGreater As Boolean
Dim rng As Range, rRow As Range
Set rng = ActiveSheet.Range("A1:B1000")
rng.Formula = "=RANDBETWEEN(1,1000)"
rng.Value = rng.Value
End Sub
Sub RedOrGreen()
Dim clr As Long, i as long
Dim rng As Range, rRow As Range
Dim arr As Variant
Const clrMore = vbGreen, clrLessEqual = vbRed
Dim t As Single
t = Timer
Set rng = Range("A1:B1000")
arr = rng.Value
For Each rRow In rng.Rows
i = i + 1
If arr(i, 2) > arr(i, 1) Then
clr = clrMore
Else
clr = clrLessEqual
End If
If rRow.Interior.Color <> clr Then
rRow.Interior.Color = clr
End If
Next
Debug.Print Timer - t
End Sub
Highlight Rows
Sub HighlightRows()
Dim t As Double: t = Timer
' Define constants (adjust).
Const PROC_TITLE As String = "Highlight Rows"
Const SMALL_COL As Long = 1
Const GREAT_COL As Long = 2
Dim RowColors(): RowColors = VBA.Array(vbGreen, vbRed)
' Reference the table range.
' Turn off screen updating.
Application.ScreenUpdating = False
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion
' Validate rows and columns.
' Validate rows.
Dim rCount As Long: rCount = trg.Rows.Count
If rCount < 2 Then
MsgBox "No data or just headers in the range '" _
& trg.Address(0, 0) & "'.", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Validate columns.
Dim cCount As Long: cCount = trg.Columns.Count
Dim MaxCol As Long: MaxCol = Application.Max(SMALL_COL, GREAT_COL)
If cCount < GREAT_COL Then
MsgBox "Column " & MaxCol & " is greater than the number " _
& "of columns (" & cCount & ") in the range ('" _
& trg.Address(0, 0) & "').", vbCritical, PROC_TITLE
Exit Sub ' screen updating will automatically get turned on
End If
' Reference and populate the helper columns.
' Insert two helper columns adjacent to the right of the table range.
trg.Offset(, cCount).Resize(, 2).Insert xlShiftToRight
' Remove this line if there is no data to the right.
' Reference the expanded table range (including the helper columns)...
Dim erg As Range: Set erg = trg.Resize(, cCount + 2) ' has headers
' ... and reference its data to be used with 'SpecialCells'.
Dim edrg As Range: Set edrg = erg.Resize(rCount - 1).Offset(1) ' no headers
' Reference the helper columns.
Dim CompareCol As Long: CompareCol = cCount + 1 ' for the auto filter
Dim crg As Range: Set crg = erg.Columns(CompareCol)
Dim irg As Range: Set irg = erg.Columns(cCount + 2)
' Write an ascending integer sequence to the Integer column.
irg.Value = ws.Evaluate("ROW(1:" & rCount & ")")
' Write the values from the criteria columns to arrays.
Dim SmallData(): SmallData = erg.Columns(SMALL_COL).Value
Dim GreatData(): GreatData = erg.Columns(GREAT_COL).Value
' Define the Compare array.
Dim CompareData(): ReDim CompareData(1 To rCount, 1 To 1)
Dim SmallVal, GreatVal, r As Long
' Write the Compare results to the Compare array
' (1 for the 1st color and 2 for the 2nd), ...
For r = 2 To rCount ' skip headers
SmallVal = SmallData(r, 1)
GreatVal = GreatData(r, 1)
If IsNumeric(SmallVal) And IsNumeric(GreatVal) Then
Select Case SmallVal
Case Is < GreatVal: CompareData(r, 1) = 1
Case Is > GreatVal: CompareData(r, 1) = 2
End Select
End If
Next r
Erase SmallData
Erase GreatData
' ... write the results from the array to the Compare column...
crg.Value = CompareData
Erase CompareData
' ... and sort the range by it.
erg.Sort crg, xlAscending, , , , , , xlYes
' Highlight the rows.
edrg.Interior.Color = xlNone ' clear previous colors
Dim vedrg As Range
For r = 1 To 2
erg.AutoFilter CompareCol, CStr(r)
On Error Resume Next ' prevent error when no filtered rows
Set vedrg = edrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False ' turn off the auto filter!!!
If Not vedrg Is Nothing Then
Debug.Print vedrg.Address ' only two areas are being highlighted
vedrg.Interior.Color = RowColors(r - 1) ' 'RowColors' is zero-based
Set vedrg = Nothing ' reset for the next iteration
End If
Next r
' Clean up.
' Sort the range by the Integer column restoring initial order.
erg.Sort irg, xlAscending, , , , , , xlYes
' Delete the helper columns.
crg.Resize(, 2).Delete xlShiftToLeft
' If you have removed the Insert-line, replace this line with:
'crg.Resize(, 2).Clear
' Turn on screen updating to immediately see the changes
' (if the worksheet is active) before OK-ing the message box.
Application.ScreenUpdating = True
Debug.Print Format(Timer - t, "00.000000")
' Inform.
MsgBox "Rows highlighted.", vbInformation, PROC_TITLE
End Sub

VBA - Loop through and copy/paste value on range based on different cell value

I have been struggling with this code. I want to loop through Column E beginning with E5, on the Sheet titled "pivot of proposal" (which is a pivot table); and every time it finds a cell with the value of "check" I want it to copy/paste value of cells A & B of the corresponding row to the sheet titled Check Payments in E & F, moving down a row each time but beginning on row 4. I tried to piece together other bits of code but it is not doing what I need it to.
Sub Loop_Check_Payments()
Dim c As Range
Dim IRow As Long, lastrow As Long, krow as long
Dim copyrow As Integer
Dim rSource As Range
Dim DataOrigin As Worksheet, DataDest As Worksheet, DataDestACH As Worksheet
On Error GoTo Whoa
'~~> Sheet Where "L" needs to be checked
Set DataOrigin = ThisWorkbook.Sheets("Pivot of proposal")
'~~> Output sheet
Set DataDest = ThisWorkbook.Sheets("CHECK PAYMENTS")
Set DataDestACH = ThisWorkbook.Sheets("ACH_WIRE PAYMENTS CASH POOLER")
Application.ScreenUpdating = False
'~~> Set you input range
Set rSource = Range("Payment_Method")
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
If c.Value = "Check" Then
DataDest.Cells(4 + IRow, 5) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(4 + IRow, 6) = DataOrigin.Cells(c.Row, 2)
IRow = IRow + 1
Else
DataDestACH.Cells(4 + kRow, 7) = DataOrigin.Cells(c.Row, 1)
DataDestACH.Cells(4 + kRow, 8) = DataOrigin.Cells(c.Row, 2)
kRow = kRow + 1
End If
Next c
Whoa:
MsgBox Err.Description
End Sub
Instead of trying to Copy/paste - you can do something like this (as PeterT alluded to in comments)
this will put values from columns A&B (ordinal 1 & 2) of the SOURCE to the same row/column in the destination:
If c.Value = "Check" Then
DataDest.Cells(c.Row, 1) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(c.Row, 2) = DataOrigin.Cells(c.Row, 2)
End If

How to sort a range in excel in a column?

I want to sort a column from smallest to largest. The column is like:
Day_Cluster
(0,5]
(10,15]
(5,10]
(15,20]
I want to sort from smallest to largest but it is not happening in MS Excel. How to achieve this?
Expected output:
(0,5]
(5,10]
(10,15]
(15,20]
A Special Sort
Manual
If your data is in column A, and you have data in column B then right-click in the column header of column B (selecting the whole column) and select Insert.
If your decimal separator is a period (dot) then use this formula in cell B1:
=VALUE(SUBSTITUTE(MID(A1,2,LEN(A1)-2),",","."))
and copy down as needed.
If your decimal separator is a comma then use this formula in cell B1:
=VALUE(MID(A1,2,LEN(A1)-2))
and copy down as needed.
Now sort your data by the B column ascending.
Delete column B or just clear the data in it.
Using VBA
Copy the code to a standard module, e.g. Module1.
The data is modified in place (no inserting, shifting...).
The decimal separator is irrelevant.
Option Explicit
Sub BubbleSortIntervalsASC()
Const ProcName As String = "BubbleSortIntervalsASC"
On Error GoTo ClearError
Const FirstCellAddress As String = "A1"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the column range.
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, fCell.Column).End(xlUp).Row
Dim rCount As Long: rCount = lRow - fCell.Row + 1
If rCount < 2 Then Exit Sub
Dim srg As Range: Set srg = fCell.Resize(rCount)
' Write the values from the source (one-column) range to the source array.
Dim sData As Variant: sData = srg.Value
' Write the same values converted to numbers to the numbers array.
Dim nData As Variant: nData = ws.Evaluate("VALUE(SUBSTITUTE(MID(" _
& srg.Address & ",2,LEN(" & srg.Address & ")-2),"","","".""))")
Dim i As Long, j As Long
Dim sT As String, nT As Double
' Bubble sort the numbers array
' and do the same 'respective' shifting in the source array.
For i = 1 To rCount - 1
For j = i To rCount
If nData(i, 1) > nData(j, 1) Then
nT = nData(i, 1): nData(i, 1) = nData(j, 1): nData(j, 1) = nT
sT = sData(i, 1): sData(i, 1) = sData(j, 1): sData(j, 1) = sT
End If
Next j
Next i
' Write the sorted values from the source array to the source range.
srg.Value = sData
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub

Excel VBA Debugging

I'm running into a "run time error 1004". I suspect this has something to do with how much data I want my code to process. Currently I am running a 246 column by 30,000 row. What I'm trying to achieve is to consolidate my data into one row item because the current system export the data into individual row as a duplicate for certain data columns. As a result, the data has a ladder/stagger effect where there's duplicate row ID with blank cells in one and data below it.
Example:
Code:
Option Explicit
Sub consolidate()
Const SHEET_NAME = "Archer Search Report"
Const NO_OF_COLS = 101
Dim wb As Workbook, ws As Worksheet
Dim irow As Long, iLastRow As Long, c As Long, count As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(SHEET_NAME)
iLastRow = ws.Range("A" & Rows.count).End(xlUp).Row
' scan up sheet
For irow = iLastRow - 1 To 2 Step -1
' if same id below
If ws.Cells(irow + 1, 1) = ws.Cells(irow, 1) Then
' scan across
For c = 1 To NO_OF_COLS
' if blank copy from below
If Len(ws.Cells(irow, c)) = 0 Then
ws.Cells(irow, c) = ws.Cells(irow + 1, c)
End If
Next
ws.Rows(irow + 1).Delete
count = count + 1
End If
Next
MsgBox iLastRow - 1 & " rows scanned" & vbCr & _
count & " rows deleted from " & ws.Name, vbInformation
End Sub
I suspect it has to do with the massive amount of data it's running and wanted to see if that is the case. If so, is there an alternative approach? Appreciate the assistance.
Note: I got this awesome code from someone(CDP1802)here and have been using it for years with smaller data set.
Here's a slightly different approach which does not require sorting by id, includes some checking for error values, and does not overwrite any data in the output.
Sub consolidate()
Const SHEET_NAME = "Archer Search Report"
Const NO_OF_COLS = 10 'for example
Dim wb As Workbook, ws As Worksheet, dataIn, dataOut
Dim i As Long, c As Long
Dim dict As Object, id, rwOut As Long, idRow As Long, vIn, vOut, rngData As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets(SHEET_NAME)
Set dict = CreateObject("scripting.dictionary")
Set rngData = ws.Range("A2:A" & ws.Cells(ws.Rows.count, 1).End(xlUp).Row).Resize(, NO_OF_COLS)
dataIn = rngData.Value 'input data as 2D array
ReDim dataOut(1 To UBound(dataIn, 1), 1 To NO_OF_COLS) 'resize "out" to match "in" array size
rwOut = 0 'row counter for "out" array
For i = 1 To UBound(dataIn, 1)
id = dataIn(i, 1) 'id for this "row"
If Not dict.exists(id) Then
'not seen this id before
rwOut = rwOut + 1
dict(id) = rwOut 'add id and row to dictionary
dataOut(rwOut, 1) = id 'add id to "out" array
End If
idRow = dict(id) 'row locator in the "out" array
For c = 2 To NO_OF_COLS
vIn = dataIn(i, c) 'incoming value
vOut = dataOut(idRow, c) 'existing value
'ignore error values, and don't overwrite any existing value in the "out" array
If Not IsError(vIn) Then
If Len(vIn) > 0 And Len(vOut) = 0 Then dataOut(idRow, c) = vIn
End If
Next c
Next i
rngData.Value = dataOut 'replace input data with output array
MsgBox "Got " & rwOut & " unique rows from " & UBound(dataIn, 1)
End Sub

Change the values in a column depending upon different criteria

I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub

Resources