复制＆amp;粘贴正在拖延我的宏

时间：2018-05-11 14:09:53

标签： excel excel-vba copy-paste vba

我有一个宏从一个工作簿中获取数据，将相当大的页面过滤到我只需要的数据，然后将值复制到我的主工作簿中的虚拟工作表中，其中不需要的行被删除，列被分类为订购更适合我的申请。 我的问题是需要一个年龄来完成并经常崩溃。 我还是VBA的新手，并且尽力使代码变得光滑，但我没有到达任何地方。我使用F8来定义减慢它的区域，它们是过滤，复制/粘贴和剪切/插入。如果有人可以提供帮助，将不胜感激。 提前致谢

中号

`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

结束Sub`

1 个答案:

答案 0 :(得分：0)

通过查看代码，可以获得大量额外代码 例如，可以使用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
相关问题
最新问题