excel 运行VBA效率变低了 原来excel运行VBA程序，很快就执行完毕，现在运行相同的程序，效率变得很慢

Posted 2023-03-25

CPU使用率一直在25左右。

数据变多，循环退出不及时是造成VBA运行速度变慢的关键。
如果VBA得运行时间随着数据量的增大，呈几何级的上升，那么肯定是循环写的不好，没有及时的退出循环。
比如，运行100行数据需要30秒，而200行需要3分钟，那么肯定是循环导致的。
好的循环，应该会有多种情况的出现。而其中或许只有1种情况是继续循环的，其它的都是退出循环，那么无疑，比一个劲的循环，效率会提高很多。追问

和数据量应该关系不大。
数据量基本上一致的。
为什么CPU总在25左右?原来运行大数据量时，CPU使用率会提高。

我运行另一个程序，就几十个空格的信息，也得看一程序，一个一个地向空格里写信息。

追答

那么，有可能是硬件问题。内存是否看过？
如果，内存的存储颗粒有部分损坏，内存还是可用的，但对程序的运行肯定是有影响的。
另外，有些时间段，机器卡了，但是在监视软件，也不一定能够看出。当然，这样的话重启肯定能够解决。如果重启解决不了，那么不是机器卡的问题。

我就我所知道的说一点。不一定能够帮到你。

参考技术A 一、数据比以前多了。
二、公式中有循环迭代计算。追问

和数据量应该关系不大。
数据量基本上一致的。
为什么CPU总在25左右?原来运行大数据量时，CPU使用率会提高。
我运行另一个程序，就几十个空格的信息，也得看一程序，一个一个地向空格里写信息。

参考技术B 首先，慢的原因是你的数据量大了
解决办法，你可以再修改你的VBA语句，聚合一下就好了追问

数据量大，为什么不是提高CPU来运行？而是一直在25左右？？

追答

这么说，
SQL1 = "SELECT distinct 会计期间, 科目说明, Sum(发生数) FROM YTD WHERE (科目说明 Like '制造费用%') GROUP BY 会计期间, 科目说明 ORDER BY 会计期间, 科目说明"
记录集RS1

我只有一个判断，就可以了，不要循环了
单元格的值就等于RS

SQL2 = "SELECT YTD.会计期间, YTD.科目说明, YTD.发生数 FROM YTD WHERE YTD.科目说明 Like '制造费用*'"
记录集RS2
x=rs2.value+x
还要加一个循环，判断

最后单元格的值 等于X

所以，我觉得是语句写的不够好，这也是我以前遇到的问题，不晓得适不适合你，如果适合给个最优！

追问

和语句没关系啊。
原来执行的时候，很快就执行完了。
最近才出现这种情况，很慢。

追答

那是因为你以前的数据量少，要不，你贴上来，叫大家看看

追问

和语句没关系的，原来运行都很快。
我QQ：57706343，你加。发给你看。。

参考技术C 发文件到我邮箱看看。[e-mail]追问

是不是我这个VBA的EXCL文件有问题了？我把VBA拷到一个新建的EXCEL文档，运行正常。求解。。。

使用 MS Access 在 excel vba 中运行代码

【中文标题】使用 MS Access 在 excel vba 中运行代码

【英文标题】：Using MS Access to run code in excel vba

【发布时间】：2015-06-24 09:14:29

【问题描述】：

我使用访问前端从 SQL Server 中提取查询。然后我将记录集导出到一个新的 Excel 工作簿。然后我想使用 excel 来运行我在 Access 中的代码。它只是循环遍历单元格并添加格式并检查某个值。我可以从访问中运行它，它将使工作簿打开循环正常。然而，它的速度非常缓慢。

如果我进入 excel 并粘贴访问正在运行的代码以进行格式化和检查。它在几秒钟内运行。但是从访问中运行它需要 10 多分钟。

如果可以做到这一点，有人有任何想法吗？

【问题讨论】：

我不太明白。 Access 是否使用自动化系统向 Excel 输入值？ Excel 是否在 Access 中运行代码？ Excel 是否在 Access 中运行代码？

访问不会花费超过 10 分钟进行格式检查。你做错了什么。粘贴我们可能会理解缺少什么的代码。也可以尝试使用模板。

这是一种格式检查，它将任何非文本单元格转换为文本。由于有很多包含数字的单元格需要采用文本格式才能将文件上传到只能采用文本格式的系统。运行需要一段时间。但是，从 Excel 模块内部运行它大约需要 10 秒。

【参考方案1】：

我已将此代码放在 Excel 中的“ThisWorkbook”对象中：

Public Sub TestScript()

    Debug.Print "Hello"

End Sub

然后使用表单上的按钮从 Access 成功调用它：

Private Sub cmdRunExcel_Click()

    Dim xl As Excel.Application
    Set xl = CreateObject("Excel.Application")

    xl.Visible = True

    xl.Workbooks.Open "C:/Your/FolderPath/And/FileName.xlsx", True, False

    xl.Run "ThisWorkbook.TestScript"

    Set xl = Nothing

End Sub

诚然，我没有给它很多代码来运行，但这里的代码至少可以在 Excel 上运行，来自 Excel...这一定比尝试在其上运行代码更好来自 Access 的 Excel。

更新：看看你是否可以通过测试来创建从 Access 到 Excel 的模块（我无法正确测试它，因为我使用的是一台工作计算机，它似乎不让我由于安全设置，运行此类代码）

Private Sub cmdRunExcel_Click()

    Dim xl As Excel.Application
    Dim myWrkBk As Excel.Workbook
    Dim myModule As VBComponent
    Dim strVb As String

    Set xl = CreateObject("Excel.Application")

    xl.Visible = True

    xl.Workbooks.Open "C:/Your/FolderPath/And/FileName.xlsx", True, False

    Set myWrkBk = xl.Workbooks.Add
    Set myModule = myWrkBk.VBProject.VBComponents.Add(vbext_ct_StdModule)

    strVb = "Public Sub TestScript()" & vbCrLf _
          & "Debug.Print 'Hello'" _
          & "End Sub"

    myModule.CodeModule.AddFromString strVb

'    xl.Run "ThisWorkbook.TestScript"

    Set myModule = Nothing
    Set myWrkBk = Nothing
    Set xl = Nothing

End Sub

【讨论】：

这将是完美的。除了每次从 Access 运行代码时我都会创建新的工作簿。它确实创建了大约 10~ 个 Excel 工作簿。每个都需要运行代码。但由于它们是新工作簿，我无法在其中添加任何模块

啊，那更复杂。我确实尝试过测试您是否可以使用此处的一些示例从 Access 中创建 Excel 模块：bit.ly/1JQqr0N 我正在使用我工作的计算机，但出现了似乎与我工作的安全设置相关的错误。不过你可能很幸运。

我已将我在更新部分尝试的内容添加到我的答案中......就像我说的，我收到了一条安全错误消息，这可能取决于我雇主的安全设置，所以它可能为你工作。这个想法是它会在你的电子表格中添加一个带有一些代码的模块。

尝试添加。这就是我所追求的。但是我收到消息“不信任对 Visual Basic 项目的编程访问”所以我猜测使其受信任的唯一方法是通过信任中心？但这意味着我将无法做到。因为它是通过 Access 创建的。感谢您迄今为止的所有帮助。

我遇到了同样的问题。我无权在工作中调整这些安全设置，但也许您可以在您的计算机上进行调整？ （显然这会降低您的文件安全性）***.com/questions/25638344/…

【参考方案2】：

如果我理解正确，您将代码从 Access 复制到 Excel 并在 Excel 中运行相同的代码，在这两种情况下，代码都会操作电子表格，Excel 中的一个速度很快，Access 中的另一个速度很慢，您可以尝试以下方法：

隐藏 Excel 窗口 (ActiveWorkbook.Windows(1).Visible = False)，同时检查 here 停止重新计算工作表 - 检查this 在 Excel 工作表中编写相同的函数（作为模板文件）并仅从 Access 运行它

我希望这会有所帮助。

通常，自动化比宏（vba 代码）慢得多。这同样适用于其他应用程序，例如。微软Word。

【讨论】：

我已经隐藏了 Excel 窗口。 MS Access 代码创建大约 10 个 Excel 文件，隐藏窗口，然后将它们保存在网络上。我试图关闭计算方法，但速度没有差异。两者都没有帮助。我会考虑添加一个模板文件并尝试一下

【参考方案3】：

如果您希望在 Excel 中运行的代码始终相同，请打开一个 Excel 模板，其中附有一个包含您的代码的宏工作簿。 然后，从 Access 中，您可以运行一系列宏，或者如果只有一个宏被传递给参数数组，当然也可以只运行一个宏：

Function RunExcelMacros( _
  ByVal strFileName As String, _
  ParamArray avarMacros()) As Boolean

Debug.Print "xl ini", Time

  On Error GoTo Err_RunExcelMacros

  Static xlApp      As Excel.Application
  Dim xlWkb         As Excel.Workbook

  Dim varMacro      As Variant
  Dim booSuccess    As Boolean
  Dim booTerminate  As Boolean

  If Len(strFileName) = 0 Then
    ' Excel shall be closed.
    booTerminate = True
  End If

  If xlApp Is Nothing Then
    If booTerminate = False Then
      Set xlApp = New Excel.Application
    End If
  ElseIf booTerminate = True Then
    xlApp.Quit
    Set xlApp = Nothing
  End If

  If booTerminate = False Then
    Set xlWkb = xlApp.Workbooks.Open(FileName:=strFileName, UpdateLinks:=0, ReadOnly:=True)

    ' Make Excel visible (for troubleshooting only) or not.
    xlApp.Visible = False 'True

    For Each varMacro In avarMacros()
      If Not Len(varMacro) = 0 Then
  Debug.Print "xl run", Time, varMacro
        booSuccess = xlApp.Run(varMacro)
      End If
    Next varMacro
  Else
    booSuccess = True
  End If

  RunExcelMacros = booSuccess

Exit_RunExcelMacros:

  On Error Resume Next

  If booTerminate = False Then
    xlWkb.Close SaveChanges:=False
    Set xlWkb = Nothing
  End If

Debug.Print "xl end", Time
  Exit Function

Err_RunExcelMacros:
  Select Case Err
    Case 0      'insert Errors you wish to ignore here
      Resume Next
    Case Else   'All other errors will trap
      Beep
      MsgBox "Error: " & Err & ". " & Err.Description, vbCritical +
vbOKOnly, "Error, macro " & varMacro
      Resume Exit_RunExcelMacros
  End Select

End Function

另外，请注意您 - 如上所示 - 必须非常严格地以正确的顺序打开、使用和关闭 Excel 对象。没有 ActiveWorkbook 之类的。

【参考方案4】：

基于 Matt Hall 的回答，但经过更改以显示您可以如何通过 Access：

调用ThisWorkbook以外的Excel模块； 调用 Excel Subs 或从 Excel 函数中检索值；和 获取通过引用传递的参数的atlered 值。

在 Excel 中名为 basTextModule 的自定义模块中：

Public Sub ShowCoolMessage()
 MsgBox "cool"
End Sub

' Add02 is explictly ByRef (the default in VBA) to show that
' the parameter will be altered and have its value changed even for
' prodedures higher up the call stack.
Public Function GetCoolAmount(Add01 As Variant, _
                            Optional ByRef Add02 As Integer) As Integer
  Add02 = Add02 + 1
  GetCoolAmount = 10 + Add01 + Add02
End Function

访问中：

设置对 Excel 的引用（VBA IDE > 工具 > 参考 ... Microsoft Excel 16.0 对象库）。 然后创建一个（有点）通用的 RunExcelCode ...

对于通过引用传递给工作的参数：

Microsoft Docs, Application.Run method (Excel) 请注意，当您将参数传递给 Excel 子程序或函数时，“您不能在此方法中使用命名参数。参数必须按位置传递”。

当声明 excelApp 使用Object 而不是Excel.Application 以确保可以检索通过引用传递给excelApp.Run 的任何参数的值。资料来源：Jaafar Tribak "Application.Run .. (Argument Passed ByRef)" at https://www.mrexcel.com/board/threads/application-run-argument-passed-byref.998132/post-4790961

在被调用的子函数或函数中，参数（除了第一个ModuleAndSubOrFunctionName）必须具有与调用模块或函数的参数数据类型相匹配的数据类型。它们可以是变体或特定的数据类型。例如，出于说明目的，Arg02 是一个整数，因此在使用 RunExcelCode(WorkbookPathAndFileName, "basTestModule.GetCoolAmount" ...) 时，GetCoolAmount 的第二个参数也必须如此。

但是，为了使您的RunExcelCode 更通用，确保Arg01、Arg02、...Arg30 参数都是变体可能是明智的；因此，您最终调用的子函数或函数的参数也是变体，例如 ...

Public Function GetCoolAmount(Add01 As Variant, _
                          Optional ByRef Add02 As Variant) As Integer
...

Public Function RunExcelCode(WorkbookPathAndFileName As String, _
                             ModuleAndSubOrFunctionName As String, _
                             Optional ByRef Arg01 As Variant, _
                             Optional ByRef Arg02 As Integer) As Variant
  ' Must be Object, not Excel.Application, to allow for parameters pass by reference
  Dim excelApp  As Object
  Dim workbook  As Excel.workbook
  
  Dim Result As Variant
  
On Error GoTo HandleErr
  
  ' Can be Excel.Application if excelApp previously declared as Object
  Set excelApp = New Excel.Application
  
'  excelApp.Visible = True ' For debugging
  
  Set workbook = excelApp.Workbooks.Open(WorkbookPathAndFileName)
  
  ' Get a value from a function or,
  ' if it is a sub a zero length string "" will be returned
  Result = excelApp.Run(ModuleAndSubOrFunctionName, Arg01, Arg02)
  
  RunExcelCode = Result

ExitHere:
  workbook.Close
  excelApp.Quit
  Set workbook = Nothing
  Set excelApp = Nothing
Exit Function

HandleErr:
  Select Case Err.number
    Case Else
      MsgBox "Error " & Err.number & ": " & Err.Description, _
        vbCritical, "RunExcelCode"
  End Select
  Resume ExitHere
End Function

测试（来自 Access），调用 Sub 和 Function：

Private Sub TestRunExcelCode()
  Dim WorkbookPathAndFileName  As String
  Dim Result As Variant
  
  WorkbookPathAndFileName = "C:\Users\YourName\Documents\MyWorkbook.xlsm"
  
  '   Run a sub
  Result = RunExcelCode(WorkbookPathAndFileName, "basTestModule.ShowCoolMessage")
  If IsNull(Result) Then
    Debug.Print "Null"
  ElseIf Result = "" Then
    Debug.Print "Zero length string"
  Else
    Debug.Print Result
  End If

  ' Will output "Zero length string"
  
  ' Get a value from a function
  Dim Arg02 As Integer
  Arg02 = 1
  Debug.Print "Arg02 Before: " & Arg02
  Result = RunExcelCode(WorkbookPathAndFileName, _
                      "basTestModule.GetCoolAmount", 1, Arg02)
  Debug.Print "Arg02 After : " & Arg02  ' Value will have changed, as desired.
  Debug.Print "Result      : " & Result
  
End Sub

编辑 01：使代码更通用的重大更改。

编辑 02：处理通过引用传递的参数的重大更改。

编辑 03：在“使您的 RunExcelCode 更通用”的案例中添加了详细信息。