How to make VBA code faster/more efficient - excel

Question

So I have designed this code to insert new entries into my master Database Log but when I run the code it is much too slow.
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim LR As Long, i As Long, iRow As Long
Set ws = ThisWorkbook.Worksheets("Data Entry")
With ws
LR = .Cells(Rows.Count, 1).End(xlUp).Row
If 2 > LR Then Exit Sub
iRow = 3
For i = 1 To LR
If .Cells(i, 1).DisplayFormat.Interior.Color = RGB(217, 230, 251) Then
Worksheets("Call Log").Rows("3:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(i, 1).Resize(1, 7).Copy ThisWorkbook.Worksheets("Call Log").Cells(iRow, "A")
End If
Next i
End With
Set ws = Nothing
End Sub
As you can see, my code goes through the range, determines if it matches my criteria (in this case the color of the cell) and then Inserts a row in the destination Worksheet and copies the data into that newly created row over and over until it finishes. I've thought of maybe having it select all of the necessary cells, copy and then insert them all at once into the destination worksheet, but I'm not sure how to go about that.
Any help is greatly appreciated!

Answer 1

One of the things you are doing obsoletely, is copying something to the clipboard, while this is not necessary: instead of
Range("<somewhere>").Copy
Range("<elsewhere>").Paste
You might simply do:
Range("<elsewhere>".Value = Range("<somewhere>").Value

Answer 2

It's always a good idea to turn off screen updating and set calculations to manual (unless you need it)
Application.SceenUpdating = false
Application.calculations = xlmanual
Then set them back to true and xlautomatic at the end of the code.
Not sure if the syntaxes is correct, I'm typing from my phone

Answer 3

If you absolutely need to copy the source formatting of the cells also, then you could use a filter and then copy only the visible cells, all in one go. Something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
Dim filterColor As Long
'
'Filter Range
filterColor = RGB(217, 230, 251)
With Range(shtData.Cells(1, 1), shtData.Cells(lastRow, 1))
.AutoFilter Field:=1, Criteria1:=filterColor, Operator:=xlFilterCellColor
End With
'
Dim rng As Range
Const lastCol As Long = 7
Dim firstRow As Long
'
'Get filtered range
'First row remains visible regardless of filter. Check it
If shtData.Cells(1, 1).Cells(1, 1).DisplayFormat.Interior.Color <> filterColor Then
firstRow = 2
Else
firstRow = 1
End If
On Error Resume Next
Set rng = Range(shtData.Cells(firstRow, 1), shtData.Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then Exit Sub 'Nothing meets criteria
'
Dim tempArea As Range
Dim rCount As Long
'
'Get required rows count
For Each tempArea In rng.Areas
rCount = rCount + tempArea.Rows.Count
Next tempArea
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + rCount - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rng.Copy shtLog.Cells(iRow, 1)
'
'Remove filter
rng.AutoFilter
End Sub
But, if you don't care about source formatting then you could use something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
'Read data in array (super fast)
Dim rng As Range
Dim arrData() As Variant
Const lastCol As Long = 7
'
Set rng = Range(shtData.Cells(1, 1), shtData.Cells(lastRow, lastCol))
arrData = rng.Value2
'
'Store relevant row numbers
Dim collRows As New Collection
Dim i As Long
Dim filterColor As Long: filterColor = RGB(217, 230, 251)
'
For i = LBound(arrData) To UBound(arrData)
If rng.Cells(i, 1).DisplayFormat.Interior.Color = filterColor Then
collRows.Add i
End If
'
'I am not a fan of using colors for filtering. It's much faster to have a separate
' column (indicator column) that can be used for that. This way we could do
' something like: If arrData(i, indCol) = expectedValue Then ...
' which is much faster than accesing cells
Next i
'
'Prepare data for writing
Dim arrFiltered() As Variant
ReDim arrFiltered(1 To collRows.Count, 1 To lastCol)
Dim r As Variant
Dim c As Long
'
i = 0
For Each r In collRows
i = i + 1
For c = 1 To lastCol
arrFiltered(i, c) = arrData(r, c)
Next c
Next r
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + collRows.Count - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'
'Write
With Range(shtLog.Cells(iRow, 1), shtLog.Cells(iRow + collRows.Count - 1, lastCol))
.Value2 = arrFiltered
End With
End Sub
Private Function GetWorksheet(ByVal sheetName As String, ByVal book As Workbook) As Worksheet
On Error Resume Next
Set GetWorksheet = book.Worksheets(sheetName)
On Error GoTo 0
End Function
The above is rushed code but proves some ways of doing the task. Other things that need to be considered are:
Are the worksheets protected? if yes, filtering and inserting rows can be an issue
Inserting rows will fail if the rows are intersecting multiple dynamic tables (listobjects)
Code needs to be changed if data doesn't start on row 1 in the source
and probably others that don't come to mind right now