Excel ScreenUpdating错误，并且在复制粘贴到另一个工作表时仍然闪烁

时间：2019-03-20 09:29:20

标签： excel vba

我是初学者，仍然学习有关宏VBA excel编程的知识。我需要社区的帮助，以解决有关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时，我运行的代码运行良好，但仍然闪烁。令人不安，我担心这会减慢代码的处理速度。

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

2 个答案:

答案 0 :(得分：2)

您需要移动此代码：

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

最后到End Sub

之前

答案 1 :(得分：0)

我无法对其进行测试，但这应该可以工作：

我的主要变更说明：

  • 尽可能早地取消保护工作表的保护，例如在导出之前（因此，如果我们实际上不导出，则无需重新保护它）。
  • 与ScreenUpdating和Calculation相同，除非出口开始，否则我们不需要停用它们。
  • 我使用循环检查了CheckColumns = Array("S", "X", "Y", "AB", "AA", "AC")列
  • 我添加了一个过程ProcessTable来处理您的多个循环。始终使用过程来重复使用相同的代码（而不是复制代码）。
  • 我建议始终激活Option Explicit：在VBA编辑器中，转到工具› 选项› Require Variable Declaration 。
  • 您必须始终指定Range或Cells等在哪个工作表中，否则Excel会猜测并且可能是错误的。
Option Explicit

Public Const SHEET_PASSWORD As String = "pass" 'define your password here!

Public Sub ExportDataImproved()
    Dim wsCopy As Worksheet
    Set wsCopy = Workbooks("Book 1.xlsm").Worksheets("Sheet 1")

    Dim wsDest As Worksheet
    Set wsDest = Workbooks("Book 2.xls").Worksheets("Sheet 1")

    Dim wsDest2 As Worksheet
    Set wsDest2 = Workbooks("Book 2.xls").Worksheets("Sheet 2")

    Dim CopyLastRow As Long
    CopyLastRow = wsCopy.Range("J10:J16").Find(what:="", LookIn:=xlValues).Offset(-1).Row

    Dim DestNextFreeRow As Long
    DestNextFreeRow = wsDest.Cells(wsDest.Rows.Count, "J").End(xlUp).Offset(1).Row

    Dim Dest2NextFreeRow As Long
    Dest2NextFreeRow = wsDest2.Cells(wsDest2.Rows.Count, "A").End(xlUp).Offset(1).Row


    'Perform some checks …
    Dim CheckColumns() As String
    CheckColumns = Array("S", "X", "Y", "AB", "AA", "AC")

    Dim CheckColumn As Variant
    Dim iRow As Long
    For iRow = 10 To 15
        If wsCopy.Cells(iRow, "W").Value <> vbNullString Then
            For Each CheckColumn In CheckColumns
                If wsCopy.Cells(iRow, CheckColumn).Value = vbNullString Then
                    MsgBox "Please fill column " & CheckColumn, vbExclamation
                    'probably Exit Sub here if this should cancel the export
                End If
                Exit For
            Next CheckColumn
        End If
    Next iRow

    If wsCopy.Cells(10, "W").Value <> vbNullString And wsCopy.Cells(10, "AD").Value = vbNullString Then
        MsgBox "Please fill column " & CheckColumn, vbExclamation
        'probably Exit Sub here if this should cancel the export
    End If


    If WorksheetFunction.CountIf(wsDest2.Range("B10:B" & Dest2NextFreeRow - 1), wsCopy.Range("B10")) > 0 Then
        If MsgBox("Double?", vbQuestion + vbYesNo, "Double data") <> vbYes Then
            Exit Sub
        End If
    ElseIf wsCopy.Range("Q5").Value <> vbNullString Then
        If MsgBox("Sure?", vbQuestion + vbYesNo, "Manual override") <> vbYes Then
            Exit Sub
        End If
    End If


    'Export starts now …
    Application.ScreenUpdating = False
    Application.Calculation = xlManual 'sometimes excel calculates values before saving files

    wsCopy.Unprotect SHEET_PASSWORD
    On Error GoTo REPROTECT 'In case of an error make sure the sheet is not left unprotected

    Dim Cell As Range
    For Each Cell In wsCopy.Range("AB10:AB15")
        Cell.Value = UCase$(Cell.Value)
    Next Cell

    wsDest.Rows(DestNextFreeRow & ":" & DestNextFreeRow + CopyLastRow - 10).Insert shift:=xlShiftDown
    wsDest.Range("A" & DestNextFreeRow) = WorksheetFunction.Max(wsDest.Range("A10:A" & DestNextFreeRow)) + 1

    wsDest.Range("L" & DestNextFreeRow - 1).Copy
    wsDest.Range("L" & DestNextFreeRow).Resize(CopyLastRow - 9, 1).PasteSpecial Paste:=xlPasteFormulas

    wsDest.Range("R" & DestNextFreeRow - 1).Copy
    wsDest.Range("R" & DestNextFreeRow).Resize(CopyLastRow - 9, 1).PasteSpecial Paste:=xlPasteFormulas

    wsCopy.Range("B10:K" & CopyLastRow).Copy
    wsDest.Range("B" & DestNextFreeRow).PasteSpecial Paste:=xlPasteValues

    wsCopy.Range("B10:K" & CopyLastRow).Copy
    wsDest.Range("B" & DestNextFreeRow).PasteSpecial Paste:=xlPasteValues

    wsCopy.Range("M10:Q" & CopyLastRow).Copy
    wsDest.Range("M" & DestNextFreeRow).PasteSpecial Paste:=xlPasteValues

    wsCopy.Range("S10:AF" & CopyLastRow).Copy
    wsDest.Range("S" & DestNextFreeRow).PasteSpecial Paste:=xlPasteValues

    For Each Cell In wsDest.Range("B" & DestNextFreeRow & ":B" & DestNextFreeRow + CopyLastRow - 10)
        Cell.Value = wsCopy.Range("B10").Value
    Next Cell


    'Copy data for wsDest2
    wsDest2.Rows(Dest2NextFreeRow).Insert shift:=xlShiftDown
    wsDest2.Range("A" & Dest2NextFreeRow) = wsDest2.Range("A" & Dest2NextFreeRow - 1).Value + 1

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

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

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


    ProcessTable wsCopy.Range("D10:D" & CopyLastRow), wsDest2.Range("D" & Dest2NextFreeRow)
    ProcessTable wsCopy.Range("AC10:AC" & CopyLastRow), wsDest2.Range("AC" & Dest2NextFreeRow)
    ProcessTable wsCopy.Range("AA10:AA" & CopyLastRow), wsDest2.Range("AA" & Dest2NextFreeRow)
    ProcessTable wsCopy.Range("AB10:AB" & CopyLastRow), wsDest2.Range("AB" & Dest2NextFreeRow)


    wsDest.Activate
    wsDest.Parent.Save 'save book 2

    'no exit sub here!
REPROTECT:
    wsCopy.protect SHEET_PASSWORD, _
        AllowFormattingCells:=True, _
        DrawingObjects:=True, _
        contents:=True, _
        Scenarios:=True

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    'Rise the actual error if one occurs
    If Err.Number <> 0 Then
        Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    End If
End Sub



Private Sub ProcessTable(ByVal TableRange As Range, ByVal ResultRange As Range)
    Dim TextTable As String

    Dim iRow As Long
    For iRow = 1 To TableRange.Rows.Count
        TextTable = TextTable & IIf(iRow = 1, vbNullString, "& ") & Trim$(TableRange.Cells(iRow, 1).Text)
    Next iRow

    ResultRange.Value = ResultRange.Value & TextTable
End Sub
相关问题
最新问题