时间戳

首页 > 解决方案 > 在复制粘贴到另一个工作表时停止闪烁/重构 Excel ScreenUpdating false 的代码

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

问题描述

我是初学者，仍在学习编程 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 Office 2016。当我运行代码时，它运行良好，但仍然闪烁。这很令人不安，我担心它会减慢处理速度。

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

标签： excel

解决方案

先说最简单的：

如果您打算进行 VBA 开发，请查看Rubberduckvba.com。这是一个插件，可以让编码变得更加容易，并教给您很多您不知道但希望您知道的知识。完全披露我是该组的贡献成员。

Option Explicit未显示在您的代码中。另外，因为您的导出代码中有一个未声明的变量cell，我假设您默认情况下没有打开它。在顶部的菜单工具>选项>编辑器选项卡>代码设置组>需要变量声明选中该框。这要求您Dim cell As Range在使用变量之前拥有。启用该选项后，您将在运行代码之前收到未定义变量的编译错误。这可能看起来像一些小事，但打开这个选项，因为它会在以后让你头疼。

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

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

我留下了大部分变量名，以便您可以更轻松地跟随我所做的重构。请注意，像 r、x、xMax 这样的变量不会提供任何有用的信息来说明它们的用途。使用描述性变量名称。未来你会感谢你的。描述性变量使代码自我记录并且更易于阅读。

注释。评论可能是某些人的热门话题。我发现描述性变量需要更少的代码。代码本身应该说明正在做什么。您的评论“'1. Find last used row ...”正在准确地说明它在做什么。lastRowInCopyArea = copyWorksheet.Range().FooBar.Row已经这么说了。保存评论以说明为什么要完成某事。从代码本身应该可以看出什么。

不需要匈牙利符号 (HN)。集成开发环境 (IDE) 可以通过菜单 Edit>Quick Info 告诉您变量的类型Ctrl+I。用字母表示类型会抑制可读性，并且是以前编码习惯的遗留物。好的变量名可以自行解决很多问题。

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

您正在隐式使用事物。您Range(Foo)正在隐式访问您所在的活动工作表。要查看此内容，请右键单击 Range 一词以调出上下文菜单并选择Definition。

执行此操作时，您可能会看到一个对话框，说明“无法跳转到'范围'，因为它是隐藏的”，现在在该对话框下显示对象浏览器（绿色）。单击确定关闭对话框。在 Classes (Red) 或 Members (Blue) 窗格区域中单击鼠标右键，然后从上下文菜单中选择Show Hidden Members 。

显示对象浏览器

单击右上角的内部关闭按钮或使用 关闭对象浏览器Ctrl+F4。现在将显示您的代码窗口。再次通过右键单击单词 Range 并选择 Show Definition 来调出上下文菜单。您将被带到隐藏的 Global 类和 Range 成员。

在此处输入图像描述

红色框显示灰色的类名Global通常是隐藏的，并且Range成员是访问的对象。为了避免这种隐式访问，使用工作表完全限定您的范围，或者 ActiveSheet.Range(Foo)如果您确实想访问活动工作表。再次这样做是明确的，并表明这是故意的。

我们已经得到了 的左侧Range(Foo)，那么另一侧呢？您还隐式访问了默认属性。你怎么想出来的？在上图中，橙色框中的 Range 一词为绿色，表示它是一个链接。单击它，您将被带到 Classes 窗格中的 Range，如下所示。Range 对象具有可以访问的成员，可以是方法（执行操作的事物）或属性（有关范围的信息）。

在此处输入图像描述

成员窗格显示您可以访问的这些成员。在“成员”窗格中向下滚动，直到_Default显示该成员。当您不包括成员访问 IERange(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

您需要将其拉入描述它正在做什么的自己的函数中。这样做将消除重复的代码。这样做的另一个好处是，如果你发现了一个错误，并且在任何调用/使用该函数的地方修复它，也将得到修复。

你的代码在做什么？它连接范围内的单元格以制作文本标签。让我们从 name 开始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在循环中分配的评论吗？这是其中的一部分。在重新打开 ScreenUpdating 之前，您可以使用Application.Calculate计算所有打开的工作簿。与重构您的 GoTo 跳转一样，请考虑您希望您的工作簿系列事件如何发生并相应地对其进行编码。

还有更多可以建议的，但这应该足够开始了。

推荐阅读