[英]Macro is running very slow as source file is too large
我有下面的代碼,它可以幫助我打開從該文件到當前工作簿的文件復制數據。 它還過濾數據並刪除不需要的行。 問題是源文件太大,文件大小最大為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
處理數據需要花費太多時間,是否有其他方法可以使此過程更快
我總是要降低宏速度的一件事是將文件擴展名更改為二進制文件。 您仍然可以擁有宏,它會將文件大小減少一半。
在我的代碼開始時,我總是:
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.