如何加速这个宏？

huangapple
go评论124阅读模式
英文:

How could I speed up this macro?

问题

我是您的中文翻译，以下是您提供的 VBA 代码的翻译部分：

  1. 我对VBA相对陌生，而这个宏在仅有少数几个条目时可能需要几分钟才能运行完成，我只是好奇我在做什么错误以及如何提高运行速度。
  3. 我尝试输入一些据说可以加快代码速度的行，然而，在测试后，运行时间没有任何差异。
  5. 子过程 CompareMacro()
  7. Application.ScreenUpdating = True
  8. Application.EnableEvents = True
  9. Application.AskToUpdateLinks = True
  10. Application.DisplayAlerts = True
  11. Application.Calculation = xlAutomatic
  12. ThisWorkbook.Date1904 = False
  13. Application.StatusBar = False
  15. Dim currentRow As Long
  16. Dim currentSearch As String
  17. Dim compareCount, arrCount As Long
  18. Dim columnCount, compareColumnCount As Variant
  19. Dim partListCount As Variant
  21. partListCount = Worksheets("PART LIST").UsedRange.Value
  22. columnCount = Worksheets("PART LIST").UsedRange.Columns.Count
  23. compareColumnCount = Worksheets("COMPARE").UsedRange.Columns.Count
  24. compareCount = 0
  25. arrCount = 0
  26. currentRow = 2
  28. For x = 1 To columnCount
  29.     If InStr(Worksheets("PART LIST").Cells(1, x).Value, "modelno") Then
  30.         compareCount = compareCount + 1
  31.     End If
  32. Next x
  34. ReDim arr(1 To compareCount) As Variant
  35. ReDim arr2(1 To compareCount) As Variant
  37. For y = 1 To columnCount
  38.     If InStr(Worksheets("PART LIST").Cells(1, y).Value, "modelno") Then
  39.         arrCount = arrCount + 1
  40.         arr(arrCount) = y
  41.         arr2(arrCount) = Worksheets("PART LIST").Cells(1, y).Value
  42.     End If
  43. Next y
  45. While (Not (IsEmpty(Worksheets("COMPARE").Cells(currentRow, 1))))
  46.     For b = 1 To compareCount
  47.         For c = 1 To UBound(partListCount)
  48.             If (partListCount(c, arr(b)) = Worksheets("COMPARE").Cells(currentRow, 1).Value) Then
  49.                 For d = 1 To compareColumnCount
  50.                     If (Worksheets("COMPARE").Cells(1, d) = arr2(b)) Then
  51.                         Worksheets("COMPARE").Cells(currentRow, d) = partListCount(c, 1)
  52.                     End If
  53.                 Next d
  54.             End If
  55.         Next c
  56.     Next b
  57.     currentRow = currentRow + 1
  58. Wend
  59. Application.ScreenUpdating = False
  60. Application.EnableEvents = False
  61. Application.AskToUpdateLinks = False
  62. Application.DisplayAlerts = False
  63. Application.Calculation = xlAutomatic
  64. ThisWorkbook.Date1904 = False
  65. ActiveWindow.View = xlNormalView
  66. End Sub

如果您需要进一步的帮助或翻译，请告诉我。

英文:

I'm relatively new to VBA, and this macro can take minutes to wrong on only a few entries and I'm just curious as to what I'm doing wrong and how to improve the runtime speeds.

I tried inputting some lines that were supposedly able to speed up my code, however, after testing there's no difference in runtime whatsoever.

  1. Sub CompareMacro()
  3. Application.ScreenUpdating = True
  4. Application.EnableEvents = True
  5. Application.AskToUpdateLinks = True
  6. Application.DisplayAlerts = True
  7. Application.Calculation = xlAutomatic
  8. ThisWorkbook.Date1904 = False
  9. Application.StatusBar = False
  10.     
  11. Dim currentRow As Long
  12. Dim currentSearch As String
  13. Dim compareCount, arrCount As Long
  14. Dim columnCount, compareColumnCount As Variant
  15. Dim partListCount As Variant
  17. partListCount = Worksheets("PART LIST").UsedRange.Value
  18. columnCount = Worksheets("PART LIST").UsedRange.Columns.Count
  19. compareColumnCount = Worksheets("COMPARE").UsedRange.Columns.Count
  20. compareCount = 0
  21. arrCount = 0
  22. currentRow = 2
  24. For x = 1 To columnCount
  25.     If InStr(Worksheets("PART LIST").Cells(1, x).Value, "modelno") Then
  26.         compareCount = compareCount + 1
  27.     End If
  28. Next x
  30. ReDim arr(1 To compareCount) As Variant
  31. ReDim arr2(1 To compareCount) As Variant
  33. For y = 1 To columnCount
  34.     If InStr(Worksheets("PART LIST").Cells(1, y).Value, "modelno") Then
  35.         arrCount = arrCount + 1
  36.         arr(arrCount) = y
  37.         arr2(arrCount) = Worksheets("PART LIST").Cells(1, y).Value
  38.     End If
  39. Next y
  41. While (Not (IsEmpty(Worksheets("COMPARE").Cells(currentRow, 1))))
  42.     For b = 1 To compareCount
  43.         For c = 1 To UBound(partListCount)
  44.             If (partListCount(c, arr(b)) = Worksheets("COMPARE").Cells(currentRow, 1).Value) Then
  45.                 For d = 1 To compareColumnCount
  46.                     If (Worksheets("COMPARE").Cells(1, d) = arr2(b)) Then
  47.                         Worksheets("COMPARE").Cells(currentRow, d) = partListCount(c, 1)
  48.                     End If
  49.                 Next d
  50.             End If
  51.         Next c
  52.     Next b
  53.     currentRow = currentRow + 1
  54. Wend
  55. Application.ScreenUpdating = False
  56. Application.EnableEvents = False
  57. Application.AskToUpdateLinks = False
  58. Application.DisplayAlerts = False
  59. Application.Calculation = xlAutomatic
  60. ThisWorkbook.Date1904 = False
  61. ActiveWindow.View = xlNormalView
  62. End Sub

答案1

得分: 2

我看不到你的工作簿的结构，但是如果我们假设你的原始代码按预期执行但速度较慢，那么可以通过一次性读取和写入所有单元格来提高速度（尽可能多）。

然而，这有一定限制。如果"COMPARE"工作表上有公式，那么你不能一次性覆盖所有单元格，因为单元格将不再包含像=1+2这样的公式，而会被覆盖为3。

所以，选项A是一次性覆盖所有内容，选项B是逐个覆盖要修改的单元格。我（未经测试的）宏如下：

  1. Public Sub CompareMacro()
  2.     ' 代码部分
  3. End Sub

Application.ScreenUpdating 和 Application.StatusBar 的内容在这种情况下没有任何改进，只会降低代码的可读性，并且如果宏失败会让用户感到不便。因此，可以将其删除。

如果你想进一步提高性能，应该重新考虑你的工作表结构，并规范化你的数据库。

英文:

I can't see the structure of your workbook, however, if we assume that your original code does what it is supposed to do but slowly, then it can be made faster by reading and writing all cells in one call (as much as possible).

There is a limitation to this, however. If there are formulas on the COMPARE worksheet, then you can't overwrite all cells at once because the cell would not contain, e.g. =1+2 anymore but would be overwritten with 3.

So Option A is to overwrite everything at once, Option B is to overwrite only cells that you want to modify, one by one. My (untested) macro is the following:

  1. Public Sub CompareMacro()
  2.     Dim partlist() As Variant: partlist = ThisWorkbook.Worksheets("PART LIST").UsedRange.Value
  3.     
  4.     Dim mCount As Long: mCount = 0
  5.     Dim mCols() As Long
  6.     Dim mVals() As Variant
  7.     Dim pCol As Long: For pCol = LBound(partlist, 2) To UBound(partlist, 2)
  8.         If InStr(1, partlist(1, pCol), "modelno") <> 0 Then
  9.             mCount = mCount + 1
  10.             ReDim Preserve mCols(1 To mCount)
  11.             mCols(mCount) = pCol
  12.             ReDim Preserve mVals(1 To mCount)
  13.             mVals(mCount) = partlist(1, pCol)
  14.         End If
  15.     Next
  16.     
  17.     Dim compare() As Variant: compare = ThisWorkbook.Worksheets("COMPARE").UsedRange.Value
  18.     
  19.     Dim cRow As Long: For cRow = LBound(compare, 1) + 1 To UBound(compare, 1)
  20.         Dim m As Long: For m = 1 To mCount: Dim mCol As Long: mCol = mCols(m): Dim mVal As Variant: mVal = mVals(m)
  21.             Dim pRow As Long: For pRow = LBound(partlist, 1) To UBound(partlist, 1)
  22.                 If partlist(pRow, mCol) = compare(cRow, 1) Then
  23.                     Dim cCol As Long: For cCol = LBound(compare, 2) To UBound(compare, 2)
  24.                         If compare(1, cCol) = mVal Then
  25.                             
  26.                             ' Option A
  27.                             compare(cRow, cCol) = partlist(pRow, 1)
  28.                             
  29.                             ' Option B
  30.                             ' ThisWorkbook.Worksheets("COMPARE").Cells(cRow, cCol) = partlist(pRow, 1)
  31.                             
  32.                         End If
  33.                     Next
  34.                 End If
  35.             Next
  36.         Next
  37.     Next
  38.     
  39.     ' Option A
  40.     ThisWorkbook.Worksheets("COMPARE").UsedRange.Value = compare
  42. End Sub

The Application.ScreenUpdating ... Application.StatusBar stuff does not make any improvement in this case, just makes the code less readable, and annoys the user if the macro fails. So, get rid of it.

If you want to further improve the performance, you should reconsider your worksheets' structure, and normalize your database.

huangapple
  • 本文由 发表于 2023年6月8日 23:36:14
  • 转载请务必保留本文链接：https://go.coder-hub.com/76433532.html
  • excel
  • vba
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定