Faster code to add a value from one cell to a range of columns

hyd1956

New Member
Joined
Jun 26, 2020
Messages
49
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi

Can you help with a quicker method to update the cells, I'm trying to add a value from one sheet to increase the value across a range on another sheet, whilst skipping any blank cells.

Here's the code I have which works, but takes ridiculously long

VBA Code:
Sub testprices()

Dim rng As Range, r As Range
Dim datasheet As Worksheet, detailssheet As Worksheet

Set datasheet = ThisWorkbook.Sheets(2)
Set detailssheet = ThisWorkbook.Sheets(3)

Lastrow = datasheet.Range("A" & Rows.Count).End(xlUp).Row

Set rng = datasheet.Range("O2:U" & Lastrow)
    
    For Each r In rng
    If r.Value <> "" Then
        r.Value = r.Value + detailssheet.Range("B9").Value
        End If
    Next r
    
    MsgBox ("complete")


End Sub

Thank you
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
One thing that should help is to temporarily disable all calculations and screen updating until you complete your loop, i.e.
VBA Code:
Sub testprices()

Dim rng As Range, r As Range
Dim datasheet As Worksheet, detailssheet As Worksheet

Set datasheet = ThisWorkbook.Sheets(2)
Set detailssheet = ThisWorkbook.Sheets(3)

Lastrow = datasheet.Range("A" & Rows.Count).End(xlUp).Row

Set rng = datasheet.Range("O2:U" & Lastrow)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For Each r In rng
    If r.Value <> "" Then
        r.Value = r.Value + detailssheet.Range("B9").Value
        End If
    Next r
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox ("complete")


End Sub
 
Upvote 0
Or you could try using an array instead of the sheet itself :

VBA Code:
Sub testprices()

Dim rng As Range, r As Range
Dim datasheet As Worksheet, detailssheet As Worksheet

Dim data_range As Variant
Dim detail_to_add

Set datasheet = ThisWorkbook.Sheets(2)
Set detailssheet = ThisWorkbook.Sheets(3)

LastRow = datasheet.Range("A" & Rows.Count).End(xlUp).Row
detail_to_add = detailssheet.Range("B9").Value

'Set rng = datasheet.Range("O10:U" & Lastrow)
'
'    For Each r In rng
'    If r.Value <> "" Then
'        r.Value = r.Value + detailssheet.Range("B9").Value
'        End If
'    Next r
   
data_range = datasheet.Range("O10:U" & LastRow)
   For x = 1 To UBound(data_range) 'rows
    For y = 1 To UBound(data_range, 2) 'columns
        data_range(x, y) = data_range(x, y) + detail_to_add
    Next y
   Next x
  
datasheet.Range("O10:U" & LastRow) = data_range
  
    MsgBox ("complete")


End Sub
 
Upvote 0
Solution
The code you are using also converts formulas to values in the process.
If that is really what you want to do, then this should be much faster.
It uses Paste Special Add

Note: You are updating columns O:U but using A to determine the last row, just check A is representative of the Last Row for O:U.

VBA Code:
Sub AddValue()

    Dim datasheet As Worksheet, detailssheet As Worksheet
    Dim Lastrow As Long
    Dim rng As Range
    Dim arr As Variant
   
    Set datasheet = ThisWorkbook.Sheets(2)
    Set detailssheet = ThisWorkbook.Sheets(3)
   
    Lastrow = datasheet.Range("A" & Rows.Count).End(xlUp).Row
   
    Set rng = datasheet.Range("O2:U" & Lastrow)
   
    ' Convert any formulas to values, which also converts "" to Blank
    arr = rng.Value
    rng = arr
   
    detailssheet.Range("B9").Copy
    ' Select Constants that are numeric which will exclude all Blank Cells
    ' Use Paste special add to increase the value.
    rng.SpecialCells(Type:=XlCellType.xlCellTypeConstants, Value:=XlSpecialCellsValue.xlNumbers) _
                .PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks:=False, Transpose:=False
   
    Application.CutCopyMode = False
    datasheet.Activate
    datasheet.Range("O2").Select
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

End Sub
 
Upvote 0
apologies, I missed the ignore empty cells bit:

VBA Code:
Sub testprices()

Dim rng As Range, r As Range
Dim datasheet As Worksheet, detailssheet As Worksheet

Dim data_range As Variant
Dim detail_to_add

Set datasheet = ThisWorkbook.Sheets(2)
Set detailssheet = ThisWorkbook.Sheets(3)

LastRow = datasheet.Range("A" & Rows.Count).End(xlUp).Row
detail_to_add = detailssheet.Range("B9").Value

'Set rng = datasheet.Range("O10:U" & Lastrow)
'
'    For Each r In rng
'    If r.Value <> "" Then
'        r.Value = r.Value + detailssheet.Range("B9").Value
'        End If
'    Next r
   
data_range = datasheet.Range("O10:U" & LastRow)
   For x = 1 To UBound(data_range) 'rows
    For y = 1 To UBound(data_range, 2) 'columns
        If Not IsEmpty(data_range(x, y)) Then data_range(x, y) = data_range(x, y) + detail_to_add
    Next y
   Next x
  
datasheet.Range("O10:U" & LastRow) = data_range
  
    MsgBox ("complete")


End Sub
 
Upvote 0
thats great - thanks for the feeedback.
 
Upvote 0
@RobP - your code is definitely much faster.
On my test data it errored out. I changed that If statement to:
VBA Code:
If data_range(x, y) <> "" And IsNumeric(data_range(x, y)) Then data_range(x, y) = data_range(x, y) + detail_to_add

Using Not IsEmpy, the addition errored out on "" and also on any text that might be in data range.
 
Upvote 0
Thanks Alex,

I just used numbers and blank cells in my test data, as he said he was adding values.

Good to know.
Rob
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,240
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top