В коде VBA слишком много циклов, что замедляет работу - PullRequest
Новая
       14

В коде VBA слишком много циклов, что замедляет работу

0 голосов
/ 24 августа 2018

У меня есть код VBA, который копирует те же данные из нескольких листов, а затем вставляет их в «основной» лист.Затем он автоматически заполняет пустые ячейки для значений сверху, а затем удаляет все строки, где H: H пустое.Однако, будучи новичком в VBA, я чувствую, что в моем коде слишком много циклов, что делает его работу медленнее.Более того, если таблица «Main» имеет отформатированную таблицу, код не удаляет ни одну строку H пусто.Однако это работает, если «Main» пусто и не отформатировано.

Еще одна вещь, которую я обнаружил, что после выполнения кода лист Excel становится менее отзывчивым.Я не могу быстро выбрать ячейки, переключаться между листами.

Пожалуйста, сообщите, если что-то можно улучшить, чтобы оно работало более эффективно. 

Private Sub CopyRangeFromMultiWorksheets1()



'Fill in the range that you want to copy
'Set CopyRng = sh.Range("A1:G1")

Dim sh As Worksheet
Dim DestSh As Worksheet
Dim rng As Range
Dim Last As Long
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng4 As Range
Dim CopyRng5 As Range
Dim CopyRng6 As Range
Dim CopyRng7 As Range
Dim cell As Range
Dim Row As Range
Dim LastrowDelete As Long



With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet" if it exist
'Application.DisplayAlerts = False
On Error Resume Next
'ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
'Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet"
 Set DestSh = Sheets("Main")
'Set DestSh = ActiveWorkbook.Worksheets.Add
' DestSh.Name = "RDBMergeSheet"

'loop through all worksheets and copy the data to the DestSh
 For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name And sh.Name <> "PAYPERIOD" And sh.Name <> 
  "TECHTeamList" Then

        'Find the last row with data on the DestSh
        Last = LastRow(DestSh)

        'Fill in the range that you want to copy
        Set CopyRng1 = sh.Range("B3")
        Set CopyRng2 = sh.Range("C3")
        Set CopyRng3 = sh.Range("D3")
        Set CopyRng4 = sh.Range("G3")
        Set CopyRng5 = sh.Range("C5")
        Set CopyRng6 = sh.Range("A8:j25")
        Set CopyRng7 = sh.Range("A28:j45")

        'Test if there enough rows in the DestSh to copy all the data
        If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If

        'This example copies values/formats, if you only want to copy the
        'values or want to copy everything look at the example below this 
  macro
        CopyRng1.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With
        CopyRng2.Copy
        With DestSh.Cells(Last + 1, "B")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With
        CopyRng3.Copy
        With DestSh.Cells(Last + 1, "C")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With

         CopyRng4.Copy
        With DestSh.Cells(Last + 1, "D")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False

        End With
         CopyRng5.Copy
        With DestSh.Cells(Last + 1, "E")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With


        CopyRng6.Copy
        With DestSh.Cells(Last + 1, "F")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With


        'Refresh the Lastrow used so that the values start from 
        'underneath copyrng6

        Last = LastRow(DestSh)
         CopyRng7.Copy
        With DestSh.Cells(Last + 1, "F")
            .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With


    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
 DestSh.Columns.AutoFit

 'Autofill the rang A2:E for values from above looking at  the last row of F
 With Range("A2:E" & Range("F" & Rows.Count).End(xlUp).Row)
 .SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With


 'Delete Entire rows where H is Blank
Application.ScreenUpdating = False
Columns("H:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True

With Application
    .ScreenUpdating = True
    .EnableEvents = True
 End With
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function

Любая помощь будет принята.

...