时间戳

首页 > 解决方案 > 由于源文件太大，宏运行非常慢

excel - 由于源文件太大，宏运行非常慢

问题描述

我有下面的代码可以帮助我打开从该文件到当前工作簿的文件复制数据。它还过滤数据并删除不需要的行。问题是源文件太大 文件大小高达 30MB 它包含 A1 范围内的数据：BG1018576

一旦文件打开，工作就是复制特定列并将其过去，它还将过滤数据并删除不需要的行。

Sub Position()
    Dim b1 As Workbook, b2 As Workbook
    Dim ws As Worksheet
    Dim src As Worksheet
    Dim trg As Worksheet
    Dim Fname As String
    Dim LR As Long
    Dim LR1 As Long

    Set b1 = ThisWorkbook 
    Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")

    If Fname = "False" Then Exit Sub

    Set b2 = Workbooks.Open(Fname)
    Set b2 = ActiveWorkbook

    For Each ws In b2.Sheets
        If ws.Visible Then
            ws.Copy after:=b1.Sheets(b1.Sheets.Count)
        End If
    Next ws

    b2.Close

    Set src = ThisWorkbook.Worksheets("CR")
    Set trg = ThisWorkbook.Worksheets("Data")
    src.Range("B:B").Copy Destination:=trg.Range("E1")
    src.Range("G:G").Copy Destination:=trg.Range("D1")
    src.Range("T:T").Copy Destination:=trg.Range("F1")
    src.Range("BB:BB").Copy Destination:=trg.Range("G1")
    src.Range("BG:BG").Copy Destination:=trg.Range("H1")        
    src.Range("D:D").Copy Destination:=trg.Range("I1")        
    src.Range("F:F").Copy Destination:=trg.Range("J1")                
    src.Delete

    With Worksheets("Data") '<--| always specify full worksheet reference (change "MyWantedSheet" with your actual sheet name)
        With .Columns("D:D") '.Resize(.Cells(.Rows.Count, "B").End(xlUp).Row) '<--| refer to wanted column range down to its last non empty cell
            .AutoFilter '<--| remove possible preeeding autofilter filtering
            .AutoFilter Field:=1, Criteria1:="=" '<--| apply current filtering
                .Resize(.Parent.Cells(.Parent.Rows.Count, "E").End(xlUp).Row - 1).Offset(1).SpecialCells(xlCellTypeVisible).Rows.Delete '<--|delete visible rows other than the first ("headers") one
        End With
        .AutoFilterMode = False '<--| remove drop-down arrows
    End With

    With Worksheets("Data") '<--| always specify full worksheet reference (change "MyWantedSheet" with your actual sheet name)
        With .Columns("H:H") '.Resize(.Cells(.Rows.Count, "B").End(xlUp).Row) '<--| refer to wanted column range down to its last non empty cell
            .AutoFilter '<--| remove possible preeeding autofilter filtering
            .AutoFilter Field:=1, Criteria1:="N" '<--| apply current filtering
                .Resize(.Parent.Cells(.Parent.Rows.Count, "E").End(xlUp).Row - 1).Offset(1).SpecialCells(xlCellTypeVisible).Rows.Delete '<--|delete visible rows other than the first ("headers") one
        End With
        .AutoFilterMode = False '<--| remove drop-down arrows
    End With

    Sheets("Data").Select
    Sheets("DATA").Range("G1:G" & Sheets("DATA").UsedRange.Rows.Count).Select
    Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End sub

处理数据花费了太多时间，有没有其他方法可以使这个过程更快

标签： excelvba

解决方案

我总是要做的一件事是降低宏的速度，就是将文件扩展名更改为二进制文件。您仍然可以使用宏，它会将文件大小减半。

在我的代码的开头，我总是有：

Sub GettingStarted()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
End Sub

在我的代码末尾，我总是有：

Sub BackToNormal()
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

如果您的代码在运行时不需要进行计算，您还可以包括

Application.Calculation = xlCalculationManual

完成后，请务必将其改回

Application.Calculation = xlCalculationAutomatic

推荐阅读