excel - 停止闪烁/重构用于Excel ScreenUpdating false的代码复制粘贴到另一个工作表上

Question

我是初学者，仍然学习有关对MS Excel VBA宏进行编程的知识。我需要社区的帮助，以使用excel上的宏代码解决我的问题。

    Sub export_data()

With Application
    .ScreenUpdating = False
    .Calculation = xlManual 'sometimes excel calculates values before saving files
End With

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim wsDest2 As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim lDestLastRow2 As Long
Dim i As Long
Dim check As Long

  'Set variables for copy and destination sheets
  Set wsCopy = Workbooks("Book 1.xlsm").Worksheets("Sheet 1")
  Set wsDest = Workbooks("Book 2.xls").Worksheets("Sheet 1")
  Set wsDest2 = Workbooks("Book 2.xls").Worksheets("Sheet 2")

  '1. Find last used row in the copy range based on data in column A
  lCopyLastRow = wsCopy.Range("J10:J16").Find(what:="", LookIn:=xlValues).Offset(-1).Row

  '2. Find first blank row in the destination range based on data in column A
  'Offset property moves down 1 row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "J").End(xlUp).Offset(1).Row
  lDestLastRow2 = wsDest2.Cells(wsDest2.Rows.Count, "A").End(xlUp).Offset(1).Row

  wsCopy.Unprotect "pass"

  For i = 10 To 15
  If Range("W" & i) <> "" And Range("S" & i) = "" Then
         MsgBox "please fill column S"
    GoTo protect

  ElseIf Range("K" & i) <> "" And Range("X" & i) = "" Then
         MsgBox "please fill column X"
    GoTo protect

  ElseIf Range("W" & i) <> "" And Range("Y" & i) = "" Then
         MsgBox "please fill column Y"
    GoTo protect

  ElseIf Range("W" & i) <> "" And Range("AB" & i) = "" Then
         MsgBox "please fill column AB"
    GoTo protect

  ElseIf Range("W" & i) <> "" And Range("AA" & i) = "" Then
         MsgBox "please fill column AA"
    GoTo protect

  ElseIf Range("W" & i) <> "" And Range("AC" & i) = "" Then
         MsgBox "please fill column AC"
    GoTo protect
  End If
  Next i

  If Range("W" & 10) <> "" And Range("AD" & 10) = "" Then
         MsgBox "please fill column AD"
    GoTo protect
  End If


  If WorksheetFunction.CountIf(wsDest2.Range("B10:B" & lDestLastRow2 - 1), wsCopy.Range("B10")) > 0 Then
    check = MsgBox("Double?", _
      vbQuestion + vbYesNo, "Double data")
      If check = vbYes Then
        GoTo export
      Else
        GoTo protect
      End If
   Else
        GoTo export
  End If

  If Range("Q5") <> "" Then
    check = MsgBox("sure?", _
      vbQuestion + vbYesNo, "Manual override")
      If check = vbYes Then
        GoTo export
      Else
        GoTo protect
      End If
   Else
        GoTo export
  End If


With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With



export:

  '3. Copy & Paste Data
        For Each cell In wsCopy.Range("AB10:AB15")
            cell.Value = UCase(cell.Value)
        Next cell

    wsDest.Rows(lDestLastRow & ":" & lDestLastRow + lCopyLastRow - 10).Insert shift:=xlShiftDown
    wsDest.Range("A" & lDestLastRow) = WorksheetFunction.Max(wsDest.Range("A10:A" & lDestLastRow)) + 1
    wsDest.Range("L" & lDestLastRow - 1).Copy
        wsDest.Range("L" & lDestLastRow).Resize(lCopyLastRow - 9, 1).PasteSpecial Paste:=xlPasteFormulas
    wsDest.Range("R" & lDestLastRow - 1).Copy
        wsDest.Range("R" & lDestLastRow).Resize(lCopyLastRow - 9, 1).PasteSpecial Paste:=xlPasteFormulas
    wsCopy.Range("B10:K" & lCopyLastRow).Copy
        wsDest.Range("B" & lDestLastRow).PasteSpecial Paste:=xlPasteValues
    wsCopy.Range("B10:K" & lCopyLastRow).Copy
        wsDest.Range("B" & lDestLastRow).PasteSpecial Paste:=xlPasteValues
    wsCopy.Range("M10:Q" & lCopyLastRow).Copy
        wsDest.Range("M" & lDestLastRow).PasteSpecial Paste:=xlPasteValues
    wsCopy.Range("S10:AF" & lCopyLastRow).Copy
        wsDest.Range("S" & lDestLastRow).PasteSpecial Paste:=xlPasteValues


    For Each cell In wsDest.Range("B" & lDestLastRow & ":B" & lDestLastRow + lCopyLastRow - 10)
        cell.Value = wsCopy.Range("B10").Value
    Next cell

   'COPY DATA for book 2 sheet 2
    wsDest2.Rows(lDestLastRow2).Insert shift:=xlShiftDown

    wsDest2.Range("A" & lDestLastRow2) = wsDest2.Range("A" & lDestLastRow2 - 1).Value + 1

    wsCopy.Range("B10:C10").Copy
    wsDest2.Range("B" & lDestLastRow2).PasteSpecial Paste:=xlPasteValues

    wsCopy.Range("E10:Z10").Copy
    wsDest2.Range("E" & lDestLastRow2).PasteSpecial Paste:=xlPasteValues

    wsCopy.Range("AD10:AF10").Copy
    wsDest2.Range("AD" & lDestLastRow2).PasteSpecial Paste:=xlPasteValues

    Dim r As Range, tabel As Range, xTabel As Range
    Dim x As Integer, xMax As Long
    'y As Long, yMax As Long
    Dim textTabel As String
    Set tabel = wsCopy.Range("d10:d" & lCopyLastRow)
    Set r = wsDest2.Range("d" & lDestLastRow2)

    xMax = tabel.Rows.Count
    For x = 1 To xMax
        Set xTabel = tabel.Range(Cells(x, 1), Cells(x, 1))
        textTabel = Trim(xTabel.Text)
        If x = 1 Then
            textTabel = textTabel
            'r.Offset(x - 1, 0).ClearContents
        Else
            textTabel = "& " & textTabel
        End If
        r = r & textTabel
     Next x


    Dim r2 As Range, tabel2 As Range, xTabel2 As Range
    Dim x2 As Integer, xMax2 As Long
    'y As Long, yMax As Long
    Dim textTabel2 As String
    Set tabel2 = wsCopy.Range("AC10:AC" & lCopyLastRow)
    Set r2 = wsDest2.Range("AC" & lDestLastRow2)

    xMax2 = tabel2.Rows.Count
    For x2 = 1 To xMax2
        Set xTabel2 = tabel2.Range(Cells(x2, 1), Cells(x2, 1))
        textTabel2 = Trim(xTabel2.Text)
        If x2 = 1 Then
            textTabel2 = textTabel2
            'r.Offset(x - 1, 0).ClearContents
        Else
            textTabel2 = "& " & textTabel2
        End If
        r2 = r2 & textTabel2
     Next x2


    Dim r3 As Range, tabel3 As Range, xTabel3 As Range
    Dim x3 As Integer, xMax3 As Long
    'y As Long, yMax As Long
    Dim textTabel3 As String
    Set tabel3 = wsCopy.Range("AA10:AA" & lCopyLastRow)
    Set r3 = wsDest2.Range("AA" & lDestLastRow2)

    xMax3 = tabel3.Rows.Count
    For x3 = 1 To xMax3
        Set xTabel3 = tabel3.Range(Cells(x3, 1), Cells(x3, 1))
        textTabel3 = Trim(xTabel3.Text)
        If x3 = 1 Then
            textTabel3 = textTabel3
            'r.Offset(x - 1, 0).ClearContents
        Else
            textTabel3 = "& " & textTabel3
        End If
        r3 = r3 & textTabel3
     Next x3


    Dim r4 As Range, tabel4 As Range, xTabel4 As Range
    Dim x4 As Integer, xMax4 As Long
    'y As Long, yMax As Long
    Dim textTabel4 As String
    Set tabel4 = wsCopy.Range("AB10:AB" & lCopyLastRow)
    Set r4 = wsDest2.Range("AB" & lDestLastRow2)

    xMax4 = tabel4.Rows.Count
    For x4 = 1 To xMax4
        Set xTabel4 = tabel4.Range(Cells(x4, 1), Cells(x4, 1))
        textTabel4 = Trim(xTabel4.Text)
        If x4 = 1 Then
            textTabel4 = textTabel4
            'r.Offset(x - 1, 0).ClearContents
        Else
            textTabel4 = "& " & textTabel4
        End If
        r4 = r4 & textTabel4
     Next x4


  'Optional - Select the destination sheet
   wsDest.Activate
   GoTo protect


protect:
  wsCopy.protect "pass", _
    AllowFormattingCells:=True, _
    DrawingObjects:=True, _
    contents:=True, _
    Scenarios:=True

    Workbooks("Book 2.xls").Save
    Exit Sub


End Sub

我正在使用Microsoft Office2016。运行代码时，它运行良好，但仍然闪烁。这很麻烦，恐怕会减慢处理速度。

有什么想法可以在代码运行时停止闪烁？

Answer 1

首先最简单的事情：

如果您打算进行VBA开发，请研究Rubberduckvba.com。它是一个外接程序，可以使编码容易得多，并且可以教您很多您不知道的知识。全面披露我是该小组的重要成员。

Option Explicit没有显示在您的代码中。另外，因为您的导出代码中有未声明的变量cell，所以我假设您默认未打开该变量。在顶部工具>选项>编辑器选项卡>代码设置组>要求变量声明的菜单下，选中该框。这要求您具有Dim cell As Range才能使用变量。启用该选项后，在运行代码之前，将得到未定义的变量的编译错误。这似乎不太重要，但是请打开此选项，因为以后可以避免头痛。

您正在使用check作为消息框结果。不要将其声明为Long，而是在键入Dim check As VbMsgBoxResult时将其声明为check=，这样您将获得智能感知和可用的枚举值。

您已将""用作空字符串的占位符。请改用vbNullString。这是一个内置常数，可以让您知道此检查是有意的。这是因为""可能是或可能是具有值"CheckValue"的字符串，该字符串中的单词已删除，仅留下了空引号。 vbNullString是明确的。

我留下了大多数变量名，因此您可以更轻松地跟随我进行的重构。请注意，变量r，x，xMax不会提供有关其用途的任何有用信息。使用描述性的变量名。将来你会谢谢你的。描述性变量使代码可以自我记录，并且更易于阅读。

注释。评论可能是某些人的热门话题。我发现描述性变量需要的代码更少。代码本身应说明正在做什么。您的评论“'1.查找上次使用的行...”完全是在说一遍。 lastRowInCopyArea = copyWorksheet.Range().FooBar.Row已经在说了。保存注释，说明执行某项操作的原因。从代码本身应该清楚什么。

不需要匈牙利表示法（HN）。集成开发环境（IDE）可以从菜单“编辑”>“快速信息Ctrl + I”中告诉您变量的类型。带有字母的类型会抑制可读性，并且是先前编码习惯的遗留物。好的变量名将自行修复很多此类问题。

您可以在导出部分的开头使用类型化的UCase$()函数而不是通用的UCase()函数，因为您正在处理字符串。



您正在隐式使用事物。您的Range(Foo)隐式访问您所在的活动工作表。要查看此右键，请单击“范围”一词以打开上下文菜单，然后选择“定义”。

当您执行此操作时，您可能会看到一个对话框，指出“由于隐藏而无法跳转到'范围'”，现在在其下显示Object Browser（绿色）。单击确定关闭对话框。在“类”（红色）或“成员”（蓝色）窗格区域中右键单击，然后从上下文菜单中选择“显示隐藏的成员”。



通过单击右上角的内部关闭按钮关闭对象浏览器，或使用Ctrl + F4。现在将显示您的代码窗口。右键单击“范围”一词，再次打开上下文菜单，然后选择“显示定义”。您将被带到隐藏的Global类和Range成员。



红色框显示灰色的类名称Global通常是隐藏的，而Range成员是所访问的内容。为避免这种隐式访问，如果您确实要访问活动表，请使用工作表或ActiveSheet.Range(Foo)完全限定范围。再次这样做是明确的，表明它是有意的。

我们有Range(Foo)的左侧，现在另一侧呢？您还将隐式访问默认属性。您如何解决？在上图中，橙色框内的单词Range为绿色，表示它是链接。单击它，您将进入“类”窗格中的“范围”，如下所示。 Range对象具有可以访问的成员，即Methods（执行操作的对象）或Properties（有关范围的信息）。



“成员”窗格显示了您可以访问的这些成员。在“成员”窗格中向下滚动，直到显示_Default成员。当您不包括IE访问Range(Foo)的成员时，您就是在访问_Default成员。由于您正在检查单元格的值，因此请使用Range(Foo).Value2限定您的成员访问权限。



您的循环可以并且应该被合并。进行第一个循环并将其与其他循环进行比较。每当您复制/粘贴并将数字标识符添加到变量中时，您就会感觉到代码的味道。每一行的起始行均为10，只有该列会变化。

    Dim r As Range, tabel As Range, xTabel As Range
    Dim x As Integer, xMax As Long
    'y As Long, yMax As Long
    Dim textTabel As String
    Set tabel = wsCopy.Range("d10:d" & lCopyLastRow)
    Set r = wsDest2.Range("d" & lDestLastRow2)

    xMax = tabel.Rows.Count
    For x = 1 To xMax
        Set xTabel = tabel.Range(Cells(x, 1), Cells(x, 1))
        textTabel = Trim(xTabel.Text)
        If x = 1 Then
            textTabel = textTabel
            'r.Offset(x - 1, 0).ClearContents
        Else
            textTabel = "& " & textTabel
        End If
        r = r & textTabel
     Next x

您需要将此功能放到描述其功能的自有功能中。这样做将消除重复的代码。这样做的另一个好处是，如果您发现了一个错误，并且在调用/使用该函数的任何位置修复了该错误，则该错误也将得到修复。

您的代码在做什么？它是将范围内的单元格串联起来以形成文本标签。让我们从名称 ConcatenateLabelFrom开始。我看到您的变量 r在循环中每次都分配。仅在所有串联完成后，您才需要这样做。请记住，这将是用于目的地的范围。循环的逻辑可以浓缩为

Private Function ConcatenateLabelFrom(ByVal concatenateArea As Range) As String
    Dim rowInArea As Integer
    For rowInArea = 1 To concatenateArea.Rows.Count
        Dim textTabel As String
        textTabel = Trim(concatenateArea.Cells(rowInArea).Text)
        If rowInArea = 1 Then
            textTabel = textTabel
        Else
            textTabel = textTabel & "& " & textTabel
        End If
    Next

    ConcatenateLabelFrom = textTabel
End Function

通过向函数提供参数的参数来调用该函数，如下所示。缩进只是为了便于阅读。

    wsDest2.Cells(lDestLastRow2, "d").Value2 = ConcatenateLabelFrom( _
                                                    wsCopy.Range( _
                                                        wsCopy.Cells(10, "d"), _
                                                        wsCopy.Cells(lCopyLastRow, "d") _
                                                    ) _
                                                )

不需要使用GoTo进行跳转。与使用GoTo相比，更好的方法是重组代码。这样做将使您的代码流更符合逻辑。它还需要您考虑如何还原 Application.ScreenUpdating/Calculation属性。

您可以通过将这些部分封装在自己的子目录中来实现。您的Protect子对象如下，并通过 Protect wsCopy, protectBook调用。出口也可以做类似的事情。

Private Sub Protect(ByVal worksheetToProtect As Worksheet, ByVal workbookToSave As Workbook)
    worksheetToProtect.Protect "pass", _
               AllowFormattingCells:=True, _
               DrawingObjects:=True, _
               contents:=True, _
               Scenarios:=True
    workbookToSave.Save
End Sub

您的部分具有



屏幕闪烁似乎正在发生，因为您在导出之前恢复了屏幕更新和自动计算。您在那里进行复制和粘贴，这就是所显示的内容。还记得我关于在循环内分配 r的评论吗？这就是其中的一部分。您可以使用 Application.Calculate计算所有打开的工作簿，然后再重新打开ScreenUpdating。与重构GoTo跳转一样，仔细考虑工作簿系列事件的发生方式并相应地进行编码。



可以提出更多建议，但这应该足以作为一个开始。