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）可以从菜单Edit> Quick Info Ctrl + I 告诉您变量的类型是什么。具有表示类型的字母会抑制可读性，并且是先前编码习惯的遗留物。好的变量名本身可以解决很多问题。

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

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

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

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

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

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

成员窗格显示您可以访问的这些成员。在“成员”窗格中向下滚动，直到显示Range(Foo)成员。如果您不包括成员访问IE _Default，则您正在访问Range(Foo).Value2成员。由于您正在检查单元格的值，因此请使用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来限定您的成员访问权限。

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

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") _
                                                    ) _
                                                )

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

Application.ScreenUpdating/Calculation

不需要使用GoTo进行跳转。与使用GoTo相比，更好的方法是重组代码。这样做将使您的代码流更加逻辑化。它还需要您考虑如何还原Protect wsCopy, protectBook属性。

您可以通过将这些部分封装在自己的子目录中来实现。您的Protect子对象如下，并通过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调用。导出也可以完成类似的操作。

具有

的部分

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

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

Answer 2

实际上，在VBA中使用GoTo语句并不是一个很好的做法，您最好将代码拆分为几个函数（甚至是模块）以使整个代码更具可读性。

然后可以使用select / case语句的if / then / else处理每个部分。闪烁可能与以下事实有关：您在部分代码执行之前在{em> 之前重新激活了ScreenUpdating。

这段代码：

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

应该在最后运行。

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

2 个答案: