加快Excel VBA的处理

Question

I've created excel vba file. However, it takes very long time to run the whole file because the total of the rows is up to 270,000 lines. Does anyone know how can I speed up the running process? Any help would be much appreciated. Thanks in advance.

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

I would start with remove as much as .activate and select you have in your code and replace it with proper sheet.cell/range selection. Then i would add this on beggining of your code

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

and this on the end of your code

Application.ScreenUpdating = previousScreenUpdating
Application.Calculation = previousCalculation

Answer 2

This should be much faster.

You should always try to do as much using arrays as possible, rather than going through your data cell-by-cell.

In addition, a dictionary-based lookup is always going to beat using Find() when you're checking things in a large loop.

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