Excel 2016 VBA 代码执行速度非常慢

Question

我遇到了 vba 代码执行缓慢的情况。我觉得难以置信，因为我有一个运行速度为 2.6 GHz 的四核 Core i7 处理器。

在我的工作簿中，我在单独的工作表上有一个输入表单，用于将发票输入数据库（工作表“frmBienNhan”）。然后在另一张工作表上，我用一个可透视表（工作表“rpt_LSGD”）汇总所有输入的发票。我使用工作表“rpt_LSGD”中的 BeforeDoubleClick 事件将用户带到不同的工作表，具体取决于他们单击的位置，以方便导航。所有代码运行良好，但与用户表单相关的代码运行速度极慢。它们完全执行大约需要 8-10 秒。

我只是 Excel VBA 的初学者，非常感谢任何帮助。

以下代码截取用户双击表单并将其显示到相应表单。此代码的一部分运行非常慢。

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
        Dim a As String, b As Range

        Application.ScreenUpdating = False

        If ActiveCell.row > 4 Then
            Select Case ActiveCell.Column
                Case Is = 4 'This column contain invoice number
                    'Take the user to Invoice input form to edit the invoice they just double-clicked on
                    a = ActiveCell.Value
                    With Sheets("frmBienNhan")
                        .Unprotect Password:="forsce15"
                        .Range("K9").Value = a
                        .Protect Password:="forsce15"
                    End With
                    Call layThTinBienNhan 'This sub entered all invoice data previously entered into the user form
                    Sheets("frmBienNhan").Select
'The code from this point forward run very quickly
                Case Is = 9
                    Select Case ActiveCell.Offset(0, 1).Value
                        Case Is = 0
                            'Copy ma bien nhan sang sheet phan cong nhiem vu
                            a = ActiveCell.Offset(0, -5).Value
                            Sheets("frmPhanCongNhVu").Range("L6").Value = a
                            'Xoa form phan cong nhiem vu
                            Sheets("frmPhanCongNhVu").Range("N13:S32").ClearContents
                            'Chuyen sang form phan cong nhiem vu
                            Sheets("frmPhanCongNhVu").Select
                        Case Is <> 0
                            'Copy ma bien nhan sang sheet phan cong nhiem vu
                            a = ActiveCell.Offset(0, -5).Value
                            Sheets("frmPhanCongNhVu").Range("L6").Value = a

                            'Xoa form phan cong nhiem vu
                            Sheets("frmPhanCongNhVu").Range("N13:S32").ClearContents

                            'Kiem tra xem bien nhan hien tai da duoc phan cong hay chua
                            If Sheets("frmPhanCongNhVu").Range("I13").Value = "N/A" Then
                                'Neu chua phan cong thi chuyen sang sheet phan cong
                                Sheets("frmPhanCongNhVu").Select
                            Else
                                'Neu da phan cong thi nhap du lieu cu vao form phan cong
                                For Each b In Sheets("frmPhanCongNhVu").Range("T13:T32")
                                    If b.Value <> "N/A" Then
                                        b.Offset(0, -6).Value = b.Offset(0, 0).Value 'TaiLieu
                                        b.Offset(0, -5).Value = b.Offset(0, 1).Value 'LoaiCongViec
                                        b.Offset(0, -6).Value = b.Offset(0, 2).Value 'NgThucHien
                                        b.Offset(0, -3).Value = b.Offset(0, 3).Value 'TrangTG
                                        b.Offset(0, -2).Value = b.Offset(0, 4).Value 'TrangVDM
                                        b.Offset(0, -1).Value = b.Offset(0, 5).Value 'NgayGiaoViec
                                    End If
                                Next b
                                'Chuyen sang form phan cong
                                Sheets("frmPhanCongNhVu").Select
                            End If
                    End Select
            End Select
        End If

        Application.ScreenUpdating = True
    End Sub

以下代码使用旧发票数据更新用户表单，以便他们可以编辑该发票。此代码运行非常慢。

Sub layThTinBienNhan()
    Dim r As Range
    Dim ws As Worksheet

    Application.ScreenUpdating = False

'Clear form
    Set ws = Sheets("frmBienNhan")
    For Each r In ws.Range("C6:K36")
        If r.Locked = False Then
            r.Value = vbNullString
        End If
    Next r

'Copy old data to user form
    With ws
        .Range("D6").Value = .Range("L11").Value 'Khach hang
        .Range("D7").Value = .Range("M11").Value 'So DT
        .Range("D9").Value = .Range("Q6").Value 'Ghi chu
        .Range("I9").Value = .Range("Q9").Value 'Thanh toan
        .Range("D34").Value = .Range("N9").Value 'Gio giao
        .Range("D35").Value = .Range("O9").Value 'Ngay giao
        .Range("D36").Value = .Range("M9").Value 'Ngay nhan
    End With
    For Each r In ws.Range("L13:L32")
        If r.Value <> "N/A" Then
            With r
                .Offset(0, -9).Value = .Offset(0, 2).Value 'Ten ho so
                .Offset(0, -8).Value = .Offset(0, 3).Value 'Ngon ngu
                .Offset(0, -7).Value = .Offset(0, 4).Value 'Trang dich
                .Offset(0, -6).Value = .Offset(0, 5).Value 'Don gia dich
                .Offset(0, -5).Value = .Offset(0, 6).Value 'So luong nhan ban
            End With
        End If
    Next r

    Application.ScreenUpdating = True
End Sub

此代码用于更新发票数据。此代码运行有点慢。

Sub capnhatBienNhan()
    Dim a As Range
    Dim r As Long

    Application.ScreenUpdating = False
    Sheets("frmBienNhan").Unprotect Password:="forsce15"

    r = Sheets("frmBienNhan").Range("R9").Value

'Update invoice info
    With Sheets("datLSGD")
        .Cells(r, 4).Value = Sheets("frmBienNhan").Range("T2").Value 'MaQLy
        .Cells(r, 5).Value = Sheets("frmBienNhan").Range("U2").Value 'NgayGD
        .Cells(r, 6).Value = Sheets("frmBienNhan").Range("V2").Value 'GioGiao
        .Cells(r, 7).Value = Sheets("frmBienNhan").Range("W2").Value 'NgayGiao
        .Cells(r, 8).Value = Sheets("frmBienNhan").Range("X2").Value 'Ghichu
        .Cells(r, 9).Value = Sheets("frmBienNhan").Range("Y2").Value 'ThanhToan
    End With

'Update invoice items info
    On Error Resume Next
    For Each a In Sheets("frmBienNhan").Range("L13:L32")
        If a <> "N/A" Then
            r = a.Value
            With Sheets("datChiTietBN")
                .Cells(r, 2).Value = a.Offset(0, -11).Value 'MaBNEntry
                .Cells(r, 3).Value = a.Offset(0, -9).Value 'TenHoSo
                .Cells(r, 4).Value = a.Offset(0, -8).Value 'NgonNgu
                .Cells(r, 5).Value = a.Offset(0, -7).Value 'SLDich
                .Cells(r, 6).Value = a.Offset(0, -6).Value 'DonGiaDich
                .Cells(r, 7).Value = a.Offset(0, -5).Value 'SLBanSao
                .Cells(r, 8).Value = a.Offset(0, -4).Value 'DonGiaBanSao
                .Cells(r, 9).Value = a.Offset(0, -3).Value 'SLCongChung
                .Cells(r, 10).Value = a.Offset(0, -2).Value 'TienCongChung
            End With
        End If
    Next a
    a = MsgBox("Cap nhat thanh cong", vbOKOnly, "Cap nhat du lieu bien nhan")

    Sheets("frmBienNhan").Protect Password:="forsce15"
    Application.ScreenUpdating = True
End Sub

当用户点击用户表单上的“更新”按钮时，以下代码将运行。它将检查用户是否正在创建新发票或更新现有发票并采取相应的操作。此代码运行速度相当慢。

Sub nhapBienNhan()
Dim lastRow As Long
Dim a As Range

Application.ScreenUpdating = False

'Unlock sheet
Sheets("frmBienNhan").Unprotect Password:="forsce15"

If Sheets("frmBienNhan").Range("H1").Value <> 0 Then
    MsgBox "Cac o co tieu de mau do khong duoc de trong."
    Exit Sub

ElseIf Sheets("frmBienNhan").Range("K9").Value <> vbNullString Then
    Call capnhatBienNhan

Else
    'creating new invoice items data
    For Each a In Sheets("frmBienNhan").Range("C13:C32")
        If a.Value <> vbNullString Then
            lastRow = Sheets("frmBienNhan").Range("Q2").Value
            With Sheets("datChiTietBN")
                .Cells(lastRow, 2).Value = a.Offset(0, -2).Value 'MaBNEntry
                .Cells(lastRow, 3).Value = a.Offset(0, 0).Value 'TenHoSo
                .Cells(lastRow, 4).Value = a.Offset(0, 1).Value 'NgonNgu
                .Cells(lastRow, 5).Value = a.Offset(0, 2).Value 'SLDich
                .Cells(lastRow, 6).Value = a.Offset(0, 3).Value 'DonGiaDich
                .Cells(lastRow, 7).Value = a.Offset(0, 4).Value 'SLBanSao
                .Cells(lastRow, 8).Value = a.Offset(0, 5).Value 'DonGiaBanSao
                .Cells(lastRow, 9).Value = a.Offset(0, 6).Value 'SLCongChung
                .Cells(lastRow, 10).Value = a.Offset(0, 7).Value 'TienCongChung
            End With
        End If
    Next a

    'Creating new invoice data
    lastRow = Sheets("frmBienNhan").Range("R2").Value
    With Sheets("datLSGD")
        .Cells(lastRow, 2).Value = Sheets("frmBienNhan").Range("Q4").Value 'TinhTrangBN
        .Cells(lastRow, 3).Value = Sheets("frmBienNhan").Range("S2").Value 'MaBN
        .Cells(lastRow, 4).Value = Sheets("frmBienNhan").Range("T2").Value 'MaKhachHang
        .Cells(lastRow, 5).Value = Sheets("frmBienNhan").Range("U2").Value 'NgayGD
        .Cells(lastRow, 6).Value = Sheets("frmBienNhan").Range("V2").Value 'GioGD
        .Cells(lastRow, 7).Value = Sheets("frmBienNhan").Range("W2").Value 'NgayGiao
        .Cells(lastRow, 8).Value = Sheets("frmBienNhan").Range("X2").Value 'GhiChu
        .Cells(lastRow, 9).Value = Sheets("frmBienNhan").Range("Y2").Value 'ThanhToan
    End With

    Sheets("frmbiennhan").Range("K9").Value = Sheets("frmBienNhan").Range("S2").Value

    MsgBox "Da luu bien nhan", vbOKOnly, "Nhap bien nhan moi"

    'Lock sheet
    ActiveSheet.Protect Password:="forsce15"
End If

Application.ScreenUpdating = True
End Sub

感谢你们付出的时间和精力。如果您需要更多说明或样本，请告诉我。

Answer 1

问题是由于范围太大，导致循环迭代次数过多。

当您创建遍历大量单元格的循环时，VBA 的速度并不快。

他们是：

For Each a In Sheets("frmBienNhan").Range("C13:C32")

如果您不使用 .range 而是执行简单的操作，则可能会更快：

For a = 13 to 32

和

if cells(12,a) <> vbNullString then