加快了excel vba的处理速度

我创build了Excel VBA文件。 但是，运行整个文件需要很长时间，因为总共有270000行。 有谁知道我怎么能加快运行过程？ 任何帮助将非常感激。 提前致谢。

Sub datemodifiedFile() Dim File1 As Object Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Set File1 = fso.getfile("C:\Users\Meg\Desktop\Master File.xlsx") If Sheets("today").Range("B1").Value = File1.DateLastModified Then Else Sheets("today").Range("B1").Value = File1.DateLastModified Dim WbB As Workbook Set WbB = Workbooks.Open(Filename:="C:\Users\Meg\Desktop\Master File.xlsx", ReadOnly:=True) Dim SheetB As Worksheet Dim lastrow As Long Set SheetB = WbB.Sheets("Sheet1") SheetB.Select Rows("1:1").Select 'Selection.AutoFilter 'ActiveSheet.Range("A:V").AutoFilter Field:=20, Criteria1:="" Columns("A:V").Select Selection.Copy ThisWorkbook.Activate Sheets("today").Select Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Columns("A:X").Select 'ActiveSheet.Range("$A$1:$X$750001").RemoveDuplicates Columns:=Array(3, 4, 6), _ Header:=xlYes Application.CutCopyMode = False lastrow = Sheets("today").Range("D" & Rows.Count).End(xlUp).Row Sheets("today").Cells(lastrow, 3).EntireRow.Delete WbB.Close False End If End Sub Sub dltnew() Dim i As Long Dim lrow As Long lrow = Sheets("today").Range("C" & Rows.Count).End(xlUp).Row For i = 2 To lrow If Sheets("today").Cells(i, 2).Value = "NEW" Then Sheets("today").Cells(i, 2).Value = "" Sheets("today").Cells(i, 1).Value = "" End If Next i End Sub Sub comdate() Dim Sheet1 As Worksheet Dim Sheet3 As Worksheet Dim lrow As Long Dim i As Long Set Sheet1 = ThisWorkbook.Sheets("main") Set Sheet3 = ThisWorkbook.Sheets("today") Sheet3.Range("A1").Value = Date Sheet3.Range("A1").NumberFormat = "dd/mm/yyyy" Sheet3.Range("A1").Font.Color = Sheet3.Range("A1").Interior.Color Sheet3.Columns("A:A").EntireColumn.Hidden = False If Sheet1.Range("B1").Value <> Sheet3.Range("A1").Value Then Sheet1.Range("B1").Value = Sheet3.Range("A1").Value lrow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row For i = 2 To lrow If Sheet1.Cells(i, 2).Value = "NEW" Then Sheet1.Cells(i, 2).Value = "" End If Next i End If End Sub Sub Con() Dim LasRow As Long Application.ScreenUpdating = False LasRow = Sheets("today").Range("C" & Rows.Count).End(xlUp).Row Sheets("today").Range("A2:A" & LasRow).Formula = "=C2&G2&I2" ActiveSheet.AutoFilterMode = False Application.ScreenUpdating = True End Sub Sub Compare() Dim mrow As Range, trow As Long With Worksheets("main") Set mrow = .Range("A2", .Range("A" & Rows.Count).End(xlUp)) End With trow = Worksheets("today").Range("A" & Rows.Count).End(xlUp).Row With Worksheets("today") For j = 2 To trow If mrow.Find(What:=.Range("A" & j).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing _ Then .Range("B" & j).Value = "NEW" Next j End With End Sub Sub getnew() Dim Sheet1 As Worksheet Dim Sheet3 As Worksheet Dim lastrow As Long Dim i As Long Dim erow As Long Set Sheet1 = ThisWorkbook.Sheets("main") Set Sheet3 = ThisWorkbook.Sheets("today") lastrow = Sheet3.Range("C" & Rows.Count).End(xlUp).Row For i = 2 To lastrow If Sheet3.Cells(i, 2).Value = "NEW" Then erow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row + 1 Sheet3.Cells(i, 2).EntireRow.Copy Destination:=Sheet1.Range("A" & erow) Application.CutCopyMode = False Sheet1.Select Range("A1:X750001").Select Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("C2") _ , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _ False, Orientation:=xlTopToBottom End If Next i End Sub Sub hidecellvalue() Dim Sheet1 As Worksheet Dim lastrow As Long Dim k As Long Set Sheet1 = ThisWorkbook.Sheets("main") lastrow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row For k = 2 To lastrow If Sheet1.Cells(k, 1).Value <> "NEW" Then Sheet1.Cells(k, 1).Font.Color = Sheet1.Cells(k, 1).Interior.Color 'Sheet1.Columns("A:A").EntireColumn.Hidden = False End If Next k End Sub Sub hideSh1column() Dim Sheet1 As Worksheet Set Sheet1 = ThisWorkbook.Sheets("main") Sheet1.Columns("A:A").EntireColumn.Hidden = True Sheet1.Columns("D:F").EntireColumn.Hidden = True Sheet1.Columns("H:H").EntireColumn.Hidden = True Sheet1.Columns("L:L").EntireColumn.Hidden = True Sheet1.Columns("N:N").EntireColumn.Hidden = True Sheet1.Columns("P:P").EntireColumn.Hidden = True End Sub Sub HideSheet3() Sheets("today").Visible = xlSheetVisible End Sub 

Answer 1

我会从与.activate一样的删除开始，并select您的代码并将其replace为正确的sheet.cell / rangeselect。 然后我会添加这个在您的代码的开始

 Dim previousScreenUpdating As Boolean previousScreenUpdating = Application.ScreenUpdating Application.ScreenUpdating = False Dim previousCalculation As XlCalculation previousCalculation = Application.Calculation Application.Calculation = xlCalculationManual 

这在你的代码的末尾

 Application.ScreenUpdating = previousScreenUpdating Application.Calculation = previousCalculation 

Answer 2

这应该快得多。

您应该尽可能多地使用数组，而不是逐个单元地处理数据。

另外，当你在一个大循环中检查事物时，基于字典的查找总是会使用Find（）来打败。

 Sub Compare() Dim mrow As Range, trow As Long, arr, r As Long Dim d As Object, rngV As Range Dim arrV, arrN, wsT As Worksheet, wsM As Worksheet Set d = CreateObject("Scripting.Dictionary") Set wsM = Worksheets("Main") Set wsT = Worksheets("today") 'get all unique values in ColA on Main arr = wsM.Range(wsM.Range("A2"), wsM.Cells(wsM.Rows.Count, 1).End(xlUp)).Value For r = 1 To UBound(arr, 1) d(arr(r, 1)) = 1 Next r Set rngV = wsT.Range(wsT.Range("A2"), wsT.Cells(wsT.Rows.Count, 1).End(xlUp)) arrV = rngV.Value 'values from colA as array arrN = rngV.Offset(0, 1).Value 'values from colB as array 'check colA against the dictionary and update colB array as needed For r = 1 To UBound(arrV, 1) If Not d.exists(arrV(r, 1)) Then arrN(r, 1) = "NEW" Next r 'repopulate ColB with updated data rngV.Offset(0, 1).Value = arrN End Sub