如何优化Excel VBA代码

Question

How can I optimize this code? It is taking a lot of time to execute.

Time of Execution

What it does: compares a list of cells in a range with another list of cells in another range and if they match, it will replace first value of first range with adjacent value of second value in the other range.

Note: This is a macro that will run on 2000-5000 rows.

Sub Update_Btn()
    Application.ScreenUpdating = False
    Application.Cursor = xlWait

    Dim status As Range, r_status As Range, l_status As Range, rl_status As Range

    lastRowcs = Worksheets("Lists").Range("E" & Rows.Count).End(xlUp).Row
    Set status = Range("D2:D" & lastRow)
    Set l_status = Worksheets("Lists").Range("E3:E" & lastRowcs)

    For Each r_status In status
        For Each rl_status In l_status
            If r_status.Value = rl_status.Value Then
                rl_status.Offset(0, 1).Copy r_status
            End If
        Next rl_status
    Next r_status

    MsgBox "Done"

    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
Exit Sub

Answer 1

Using arrays - Sheet "GB_Data" Rows: 5,001; Sheet "Lists" Rows: 5,001; Time: 6.438 sec Sheet "GB_Data" Rows: 5,001; Sheet "Lists" Rows: 5,001; Time: 6.438 sec

---

Option Explicit

Public Sub UpdateBtn()

    Const WS1_NAME = "GB_Data"
    Const WS2_NAME = "Lists"

    Const START_ROW1 = 2    'in GB_Data
    Const START_ROW2 = 2    'in Lists

    Const COL1 = "D"        'in GB_Data
    Const COL2 = "E"        'in Lists
    Const COL3 = "F"        'in Lists

    Dim ws1 As Worksheet:   Set ws1 = ThisWorkbook.Worksheets(WS1_NAME)
    Dim ws2 As Worksheet:   Set ws2 = ThisWorkbook.Worksheets(WS2_NAME)
    Dim lr1 As Long:        lr1 = ws1.Cells(ws1.Rows.Count, COL1).End(xlUp).Row
    Dim lr2 As Long:        lr2 = ws2.Cells(ws2.Rows.Count, COL2).End(xlUp).Row
    Dim arr1 As Variant:    arr1 = ws1.Range(COL1 & START_ROW1 & ":" & COL1 & lr1).Formula
    Dim arr2 As Variant:    arr2 = ws2.Range(COL2 & START_ROW2 & ":" & COL3 & lr2).Formula

    Dim r1 As Long, r2 As Long

    For r1 = 1 To UBound(arr1)
        For r2 = 1 To UBound(arr2)
            If arr1(r1, 1) = arr2(r2, 1) Then arr1(r1, 1) = arr2(r2, 2)
        Next r2
    Next r1
    ws1.Range(COL1 & START_ROW1 & ":" & COL1 & lr1).Formula = arr1
End Sub

---

.

Test data

---

Sheet "GB_Data" - Before

Sheet "Lists"

---

.

Sheet "GB_Data" - After