Looping function optimisation - currently running slow - vba

Question

I was wondering if anyone can offer advice on the following looping code I have compiled. When I run this from my laptop it processes really quickly within 2-3 seconds however I run this on a works computer and it runs really slowly and takes 10+ minutes to do the 3000-4000 rows.
Dim LastRow As Long
Dim Cell, Rng, Table As Range
'Turn off Screen updating - Speed process - Turn back on prior to Exit Sub
Application.ScreenUpdating = False
Sheets("Del Data").Select
'Validate Data Exists in Range
If Range("B3").Value = "" Then
MsgBox "No Data Available to calculate." & vbNewLine & _
"Please ensure first consigment number is pasted in cell B3." & vbNewLine & vbNewLine & _
"For assistance please refer to user manual supplied with file.", _
vbCritical, "Error Compiling Stop Calculator"
Application.ScreenUpdating = True
Exit Sub
End If
'Identify Last possible row and set Range
With ActiveSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Set Rng = Range("B3:B" & LastRow)
'**********************************
' Calculate unique values
'**********************************
For Each Cell In Rng
Cell.Offset(0, 33).Value = Trim(Left(Cell.Offset(0, 5).Value, 3))
Cell.Offset(0, 34).Value = Trim(Left(Cell.Offset(0, 7).Value, 3))
Cell.Offset(0, 35).Value = Trim(Left(Cell.Offset(0, 17).Value, 3))
Cell.Offset(0, 38).Value = Trim(Cell.Offset(0, 21).Value)
Cell.Offset(0, 36).Value = Cell.Offset(0, 34).Value & Cell.Offset(0, 33).Value & Cell.Offset(0, 38).Value
Cell.Offset(0, 37).Value = Cell.Offset(0, 34).Value & Cell.Offset(0, 34).Value & Cell.Offset(0, 38).Value
Next
Application.ScreenUpdating = True
Exit Sub
Is there any possible way to improve the code above to allow this to speed up? I understand as this is running fine on my laptop it might just be a computer issue with my works PC although specs of the PC is really good and definitely up to the task.

Answer 1

?
Dim i As Long
'**********************************
' Calculate unique values
'**********************************
With ActiveSheet
For i = 3 To LastRow
.Cells(i, 35).Value = Trim$(Left$(.Cells(i, 7).Value, 3))
.Cells(i, 36).Value = Trim$(Left$(.Cells(i, 9).Value, 3))
.Cells(i, 37).Value = Trim$(Left$(.Cells(i, 19).Value, 3))
.Cells(i, 40).Value = Trim$(Left$(.Cells(i, 23).Value, 3))
.Cells(i, 38).Value = .Cells(i, 36).Value & .Cells(i, 35).Value & .Cells(i, 40).Value
.Cells(i, 39).Value = .Cells(i, 36).Value & .Cells(i, 36).Value & .Cells(i, 40).Value
Next i
End With

Answer 2

i used a VBA array to make things faster, and a bit to tweaking here and there.
I didn't test the code, so make a copy of your data first.
Option Explicit
Sub Test()
'Sheets("Del Data").Select
With thisworkbook.Sheets("Del Data")
'Validate Data Exists in Range
If .Range("B3").Value = vbNullString Then
MsgBox "No Data Available to calculate." & vbNewLine & _
"Please ensure first consigment number is pasted in cell B3." & vbNewLine & vbNewLine & _
"For assistance please refer to user manual supplied with file.", _
vbCritical, "Error Compiling Stop Calculator."
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'i declared the variables after the condition to exit sub
Dim LastRow As Long, i&
Dim Rng As Range
Dim RngArray() 'is a variant type array, used to fast up the process
'Identify Last possible row and set Range
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set Rng = .Range(.Cells(3, 2), .Cells(LastRow, 2)) '"B3:B" & LastRow)
RngArray = .Range(.Cells(1, 2), .Cells(LastRow, 2 + 39)).Value2
'**********************************
' Calculate unique values
'beware: Cell.Offset(0, 0) is converted in my coding to RngArray(i, 1)
'**********************************
For i = 3 To LastRow
'Cell.Offset(0, 33).Value = Trim(Left(Cell.Offset(0, 5).Value, 3))
RngArray(i, 34) = Left(Trim(RngArray(i, 6)), 3)
'Cell.Offset(0, 34).Value = Trim(Left(Cell.Offset(0, 7).Value, 3))
RngArray(i, 35) = Left(Trim(RngArray(i, 8)), 3)
'Cell.Offset(0, 35).Value = Trim(Left(Cell.Offset(0, 17).Value, 3))
RngArray(i, 36) = Left(Trim(RngArray(i, 18)), 3)
'Cell.Offset(0, 38).Value = Trim(Cell.Offset(0, 21).Value)
RngArray(i, 39) = Left(Trim(RngArray(i, 22)))
'Cell.Offset(0, 36).Value = Cell.Offset(0, 34).Value & Cell.Offset(0, 33).Value & Cell.Offset(0, 38).Value
RngArray(i, 37) = RngArray(i, 35) + RngArray(i, 34) + RngArray(i, 39)
'Cell.Offset(0, 37).Value = Cell.Offset(0, 34).Value & Cell.Offset(0, 34).Value & Cell.Offset(0, 38).Value
RngArray(i, 38) = 2 * RngArray(i, 35) + RngArray(i, 39) 'OP readed twice same Cell , i used *2, might be OP miss
Next i
'write back values to sheet
.Range(.Cells(1, 2), .Cells(LastRow, 2 + 39)).Value2 = RngArray
End With
Set Rng = Nothing
Erase RngArray
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With
Exit Sub