Speed this VBA Up? - vba

Question

Is there a way to speed this code up? I need it to remove and write the same content to the cell to force other VBA code to run that's on another column. Which is what it does, just super damn slow. And there is sometimes 2000 entries/rows on this sheet. Its about 3 seconds per cell, and it almost maxes my CPU out lol. (i7 6850k # 4.4ghz).
Reason for it, is sometimes the data is copied from an old version of the spreadsheet to a new version, and the VBA updated columns wont update, unless I physically change the cell its checking.
Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
r = r + 1
End If
Next cell
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", _
AllowSorting:=True, AllowFiltering:=True
End Sub
The code in the other VBA section is
If StrComp("pp voice", Target.Value, vbTextCompare) = 0 Then
Target.Value = "PP Voice"
Target.Offset(0, 8).Value = "N\A"
Target.Offset(0, 8).Locked = True
Target.Offset(0, 10).Value = "N\A"
Target.Offset(0, 10).Locked = True
End If
Target.Value is referring to the E column in the first piece of code. At the moment I have the first piece attached to a button, but it's way to slow. And the target machines are no where near as powerful as mine.

Answer 1

Use application.enableevents = false and application.calculation = xlcalculationmanual. Turn them back on before exiting. You must be either triggering an large event or complex calculation cycle if it it taking 3 seconds per cell.
Change,
Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
r = r + 1
End If
Next cell
... to,
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cell As Range
With ThisWorkbook.Sheets("Sales Entry")
For Each cell In .Range("E2:E10")
If CBool(Len(cell.Value2)) Then
cell = cell.Value2
End If
Next cell
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

Answer 2

Try this
Option Explicit
Sub ForceUpdate()
On Error GoTo Cleanup
Dim SalesEntrySheet As Worksheet
Set SalesEntrySheet = ThisWorkbook.Sheets("Sales Entry")
Application.ScreenUpdating = False ' etc..
SalesEntrySheet.Unprotect "password!"
Dim cell As Range, r As Long
Dim ArrayPos As Long
Dim SalesEntrySheetArray As Variant
With SalesEntrySheet
'Starting with row one into the array to ease up the referencing _
so Array entry 2 will be for row 2
SalesEntrySheetArray = .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)
'Clearing the used range in Col E
'If you are using a WorkSheet_Change for the second part of your code then you should rather make this a loop
.Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value = ""
'Putting the values back into the sheet
For ArrayPos = 2 To UBound(SalesEntrySheetArray, 1)
.Cells(ArrayPos, "E").Value = SalesEntrySheetArray(ArrayPos, 1)
Next ArrayPos
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, _
AllowFiltering:=True
End Sub

Answer 3

Try to use with statement.
and take a look at Optimizing VBA macro
Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
With ThisWorkbook.Sheets("Sales Entry")
For Each cell In .Range("E2:E10")
If Len(cell) > 0 Then
Dim old As String
old = cell.Value
.Cells(4, r) = ""
.Cells(4, r) = old
r = r + 1
End If
Next cell
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, AllowFiltering:=True
End Sub