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

[hyd1956]

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

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

 

[Joe4]

One thing that should help is to temporarily disable all calculations and screen updating until you complete your loop, i.e.

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

 

[RobP]

Or you could try using an array instead of the sheet itself :

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

 

[Alex Blakenburg]

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.

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

 

[hyd1956]

That works perfectly, thanks!

 

[RobP]

apologies, I missed the ignore empty cells bit:

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

 

[RobP]

thats great - thanks for the feeedback.

 

[Alex Blakenburg]

@RobP - your code is definitely much faster.
On my test data it errored out. I changed that If statement to:

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.

 

[RobP]

Thanks Alex,

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

Good to know.
Rob