Скопируйте и вставьте мой макрос

Question

У меня есть макрос, который берет данные из одной рабочей книги, фильтрует довольно большую страницу до данных, которые мне нужны, а затем копирует значения на фиктивный лист в моей главной книге, где ненужные строки удаляются, а столбцы сортируются в заказ больше подходит для моего приложения. моя проблема в том, что для завершения требуется возраст и довольно часто происходит сбой. Я все еще новичок в VBA и старался изо всех сил скользить по коду, но никуда не денусь. Я использовал F8, чтобы определить области, которые замедляют его, и это фильтрация, копирование / вставка и вырезка / вставка. Если кто-то может помочь, это будет с благодарностью. Заранее спасибо

M

`Sub NEW_OPS_AWAY_REPORT()


MsgBox ("BOTTLENECKS AND OPS AWAY SPREADSHEET & GEARSHOP WORK TO LIST FROM REPORT CENTRE MUST BE OPEN FOR THIS REPORT TO FUNCTION CORRECTLY")

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Application.DisplayStatusBar = False

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

Windows("DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm").Activate
Sheets("WIP by Op").Visible = True
Sheets("WIP by Op").Range("$A$1:$Q$47290").AutoFilter Field:=1, Criteria1:="TS1H124*", Operator:=xlFilterValues
Windows("PRESS QUENCH FIRST OFF DATABASE.xlsm").Activate
Sheets("REPORT DATA TRANSFER").Visible = True
Sheets("REPORT DATA TRANSFER").Select
Cells.Select
Selection.ClearContents
Windows("DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm").Activate
Sheets("WIP by Op").Select
Cells.Select
Selection.Copy
Windows("PRESS QUENCH FIRST OFF DATABASE.xlsm").Activate
ActiveSheet.Paste
Range("F:F,G:G,H:H,M:M,P:P,Q:Q").Select
Range("Q1").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("A:K").Select
Columns("A:K").EntireColumn.AutoFit
Columns("J:J").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("I:I").Select
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Columns("J:J").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Cut
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Columns("J:J").Select
Selection.Cut
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Application.Calculation = xlCalculationAutomatic
Range("A1:K1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort.SortFields. _
    Clear
ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort.SortFields. _
    Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
    DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("REPORT DATA TRANSFER").AutoFilter.Sort
    .header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Sheets("Ops Away Report").Select
Columns("A:K").Select
Selection.ClearContents
Sheets("REPORT DATA TRANSFER").Select
Columns("A:K").Select
Selection.Copy
Sheets("Ops Away Report").Select
Range("A1").Select
ActiveSheet.Paste
Range("A:A,E:E,F:F,I:I,J:J").Select
Range("J1").Activate
Application.CutCopyMode = False
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Range("A1:L1").Select
Selection.AutoFilter
Columns("B:B").Select

Sheets("REPORT DATA TRANSFER").Visible = False



Dim lastRow As Long

lastRow = Range("A2").End(xlDown).Row

For Each Cell In Range("A2:Q" & lastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
    Cell.Interior.ColorIndex = 34 ''color to preference
Else
    Cell.Interior.ColorIndex = xlNone ''color to preference or remove
End If
Next Cell



Columns("D:D").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 7.43
Range("A1:O1").AutoFilter

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

Application.DisplayStatusBar = True

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

End Sub`

Answer 1

Просматривая ваш код, там много лишнего кода.
Например, добавление рамки вокруг каждой ячейки можно сделать с помощью Selection.Borders.LineStyle = xlContinuous

Этот код начинается с закрытия двух рабочих книг.Обновите переменные Const, указав правильные пути к файлам.
Возможно, вам все равно придется отключить события, в зависимости от того, какой код находится в других книгах.

Public Sub New_Ops_Away_Report()

    Const BottleNecks_Path As String = "C:\Somefolder\DAILY BOTTLENECKS ANALYSIS & OPS AWAY.xlsm"
    Const OpsAway_Path  As String = "C:\Somefolder\PRESS QUENCH FIRST OFF DATABASE.xlsm"

    Dim wrkBk_BottleNeck As Workbook
    Dim wrkbk_OpsAway As Workbook

    Dim rWIP_LastCell As Range
    Dim rReport_LastCell As Range

    Set wrkBk_BottleNeck = Workbooks.Open(Filename:=BottleNecks_Path)
    Set wrkbk_OpsAway = Workbooks.Open(Filename:=OpsAway_Path)

    'Clear the contents of the named sheet.
    wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Cells.ClearContents

    With wrkBk_BottleNeck
        'Find the last populated cell on the worksheet.
        Set rWIP_LastCell = LastCell(.Worksheets("WIP by OP"))
        With .Worksheets("WIP by OP")
            With .Range(.Cells(1, 1), rWIP_LastCell)
                'Add a filter from A1 to the last populated cell.
                .AutoFilter Field:=1, Criteria1:="TS1H124*", Operator:=xlFilterValues
                .Copy Destination:=wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Range("A1")
            End With
        End With
    End With

    With wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER")

        ''''''''''''''''''''''''
        'This bit is confusing in your code.
        'I think it's trying to do as below, but I've commented out the last line
        'as it appears to clear the data you just copied over.
        .Range("F:F,G:G,H:H,M:M,P:P,Q:Q").Delete Shift:=xlToLeft
        .Columns("A:K").EntireColumn.AutoFit
        '.Columns("A:J").EntireColumn.ClearContents
        ''''''''''''''''''''''''

        'Find last populated cell on the worksheet.
        Set rReport_LastCell = LastCell(wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER"))

        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("A1").Resize(rReport_LastCell.Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange wrkbk_OpsAway.Worksheets("REPORT DATA TRANSFER").Range("A1").Resize(rReport_LastCell.Row, rReport_LastCell.Column)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        .Range("A1").Resize(rReport_LastCell.Row, rReport_LastCell.Column).Borders.LineStyle = xlContinuous

    End With

End Sub

Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range

    Dim lLastCol As Long, lLastRow As Long

    On Error Resume Next

    With wrkSht
        lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row

        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1

        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0

End Function