加快excel vba的处理

Question

我已经创建了 excel vba 文件。但是，运行整个文件需要很长时间，因为总行数高达 270,000 行。有谁知道我怎样才能加快运行过程？任何帮助将非常感激。提前致谢。

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 开始，然后用适当的 sheet.cell/range 选择替换它。 然后我会在你的代码开始时添加这个

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