VBA编程新手，需要帮助优化VBA代码

Question

晚上好。。。

我对VBA很陌生。。。我只玩了大约一周，需要帮助优化宏。

目前，它运行大约需要23秒。。。希望能把它降一点。

第一步是按下按钮"选择文件位置"然后将DB中的一个表下载到一个名为"隐藏"的工作表中，最后将B:L列从"隐藏"复制到"UPS电价"

非常感谢任何建议

Sub Selectfile()
Dim filename As String
filename = Application.GetOpenFilename(MultiSelect:=False)
Range("c2") = filename
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sQRY As String
Dim rng As Range
Dim cell As Range
Dim sourcefile As String

sourcefile = Sheet1.Range("C2")
Sheets("Hidden").Visible = True
Set cnn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set rng = Sheet9.Range("B1:B762")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sourcefile & ";"
sQRY = "SELECT * FROM Tariff"
rs.CursorLocation = adUseClient
rs.Open sQRY, cnn, adOpenStatic, adLockReadOnly
Application.ScreenUpdating = False
Sheet9.Range("A1").CopyFromRecordset rs
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
For Each cell In rng
If cell <> "Letter" And cell <> "NDA" And cell <> "NDAS" And cell <> "2DA" And cell <> "3DS" And cell <> "GND" Then cell.Value = cell.Value * 1
Next cell
    Sheets("Hidden").Select
    Range("B1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("UPS Tariff").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Sheets("Hidden").Select
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Clear
    Sheets("Info").Select
Sheets("Hidden").Visible = xlVeryHidden
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

Answer 1

您正在进行OLEDB连接，这可能会减慢整个过程。尽管如此，在代码中还是有一些可以改进的地方：

• 1） 不要做那么多范围的选择

• 2） 请尝试在代码中使用with语句。这大大加快了你的进程。

  例如以下代码：

  Sheets("Hidden").Select
  Range("B1").Select
  Range(Selection, Selection.End(xlToRight)).Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.Copy
  Sheets("UPS Tariff").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
  Range("A1").Select
  Sheets("Hidden").Select
  Range("A1").Select
  Range(Selection, Selection.End(xlToRight)).Select
  Range(Selection, Selection.End(xlDown)).Select
  Application.CutCopyMode = False
  Selection.Clear
  Sheets("Info").Select
  

可以转换成这样的东西：

    With Sheets("Hidden")
       'copy your selection
       .Range(.cells(1,2), .cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Copy' e.g. if you want to select the whole area in the worksheet
       'paste selection to the destination cell
       Sheets("UPS Tariff").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
           :=False, Transpose:=False
       Application.CutCopyMode = False'gets rid of the highlighted copy area under your Sheets workbook
       'clears the initial selection
       .Range(.cells(1,2), .cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Clear
    End With
    Sheets("Info").Select

这不仅使代码对VBA处理器更有效率，而且在您需要查看/更改代码时，它对您来说也更可读。

真正加速过程的另一件事是以下几行：

Application.ScreenUpdating = False

每当执行新的代码行时，上述操作将停止屏幕闪烁。

Application.Calculation = xlCalculationManual

每当您对工作表进行更改时，上述操作将停止所有要重新计算的公式。

Application.EnableEvents = false

另一个，它禁用所有工作表事件，如worksheet_Activate, Worksheet_Change, ...

但是，您需要确保，一旦所有代码都完成运行，您将再次打开这些功能（否则，您的单元格将停止重新计算，屏幕将停止刷新）。

通常情况下，我所做的是创建一个新模块，在其中放置所有支持的代码。在那里我创建了以下两个函数：

Public Sub EnableExcel()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub
Public Sub DisableExcel()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
End Sub

正如您所看到的，这些函数被标记为public，因此可以从工作簿中的任何位置访问。

然后我的程序看起来是这样的：

Private Sub DoSomeStuff()
    On Error GoTo EarlyExit
    Call DisableExcel
    'this will fail as it is division by zero
    MsgBox 1 / 0
EarlyExit:
    Call EnableExcel
    If Err.Description <> vbNullString Then MsgBox Err.Description
End Sub

你能看到的是重要的错误捕捉器。我真的建议在网上阅读更多关于这些的内容。基本上，代码在这里所做的是，如果某个东西在代码执行过程中失败（我举了一个例子，你试图除以零），那么代码不会完全失败，但会向用户显示错误消息和错误描述。此外，它还确保如果代码失败，无论发生什么情况，都会执行EnableExcel宏。

这些真的只是我能给的一些建议。你使用VBA的次数越多，阅读的内容越多（例如StackOverflow），你就变得越好。祝你好运