Экран ExcelОбновляет ложь и продолжает мигать при копировании и вставке на другой лист

Question

Я новичок и до сих пор учусь программированию на макро 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, когда я бегу код работает нормально, но все еще мерцает.Это беспокоит, и я боюсь, что это замедлит процесс кодирования.

Есть идеи, как остановить мерцание во время выполнения кода?

Answer 1

Вам нужно переместить этот код:

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

в конец, непосредственно перед End Sub

Answer 2

Я не смог проверить это, но это должно сработать:

Мои основные изменения объяснили:

• Снимите защиту листа как можно позже, например, прямо перед экспортом (поэтому мы не делаемне нужно восстанавливать его, если мы на самом деле не экспортируем).
• То же самое для ScreenUpdating и Calculation, нам не нужно деактивировать их, пока не начнется экспорт.
• Я использовалцикл для проверки столбцов CheckColumns = Array("S", "X", "Y", "AB", "AA", "AC")
• Я добавил процедуру ProcessTable, которая обрабатывает несколько ваших циклов.Всегда используйте процедуры для повторного использования одного и того же кода (вместо копирования кода).
• Я рекомендую всегда активировать Option Explicit: в редакторе VBA перейдите к Инструменты ›Параметры › Требуется объявление переменной .
• Необходимо всегда указывать, в каком листе 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