代码优化加速

luketools · 发表于 2024-3-7 20:35

本帖最后由 luketools 于 2024-3-7 20:40 编辑

求教各位大神，我做了一个出货单，写了一个change事件代码，因为库存规格有上万种，采用循环时检索前面的规格速度还可以，但如果检索的内容在最后面速度就会比较慢，求助各位有没有什么优化的方法，本人代码处于菜鸟水平，目前只能写到这个水平了。
本来应该用数组形式应该会更快，但是在change事件中不会用数组，也不知道能不能用。

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Application.ScreenUpdating = False
x = Sheet1.[d65536].End(xlUp).Row - 3
y = Sheet2.[d65536].End(xlUp).Row
c = Target.Column
r = Target.Row
If Target.Count = 1 Then
  If Target <> 0 Then
   If c = 3 And r > 9 And r < x Then    '当输入新规格时自动调取单价；
      For k = 3 To y
            Cells(r, 3) = UCase(Cells(r, 3)) '将cells(r,3)单元格中的字符串全部转换成大写，然后赋予cells(r,3)
         If Cells(r, 3) = Sheet2.Cells(k, 4) Then
            Cells(r, 5) = Application.Round(Sheet2.Cells(k, 12), 1) '调用工作表函数四舍五入保留一位小数
            Exit For
         End If
      Next
   End If

   If c = 4 And r > 9 And r < x Then    '当出货数量大于等于500时，单价自动打99折,大于等于1000时，单价自动打98折；
      For k = 3 To y
         If Cells(r, 3) = Sheet2.Cells(k, 4) Then
            If Cells(r, 4) < 500 Then
               Cells(r, 5) = Application.Round(Sheet2.Cells(k, 12), 1)
               ElseIf Cells(r, 4) >= 500 And Cells(r, 4) < 1000 Then
               Cells(r, 5) = Application.Round(Sheet2.Cells(k, 12) * 0.99, 2) '打折后保留2位小数
               ElseIf Cells(r, 4) >= 1000 Then
               Cells(r, 5) = Application.Round(Sheet2.Cells(k, 12) * 0.98, 2) '打折后保留2位小数
            End If
            Exit For
         End If
      Next
   End If

  End If
End If

Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

shiruiqiang · 发表于 2024-3-7 22:13

建议改成数组，不要反复操作单元格

Enocheasty · 发表于 2024-3-7 23:07

不知道你的数据源有没有内在的顺序，如果排个序的话，可以二分查找，会快很多

luketools · 发表于 2024-3-8 09:27

shiruiqiang 发表于 2024-3-7 22:13
建议改成数组，不要反复操作单元格

如何修改为数组，可否帮忙改一下，水平有限，不会弄

luketools · 发表于 2024-3-8 09:28

Enocheasty 发表于 2024-3-7 23:07
不知道你的数据源有没有内在的顺序，如果排个序的话，可以二分查找，会快很多

没有排序，如果排序的话怎么写

考试加油站 · 发表于 2024-3-8 10:22

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsSheet1 As Worksheet
Dim wsSheet2 As Worksheet
Dim x As Long
Dim y As Long
Dim c As Integer
Dim r As Integer
Dim k As Integer
Dim searchValue As String
Dim searchResult As Range
Dim qty As Double
Dim unitPrice As Double
Dim discount As Double
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wsSheet1 = ThisWorkbook.Sheets("Sheet1")
Set wsSheet2 = ThisWorkbook.Sheets("Sheet2")
x = wsSheet1.Cells(wsSheet1.Rows.Count, "A").End(xlUp).Row - 3
y = wsSheet2.Cells(wsSheet2.Rows.Count, "A").End(xlUp).Row
c = Target.Column
r = Target.Row
If Target.Count = 1 Then
If Target.Value <> 0 Then
searchValue = UCase(Target.Value)
If c = 3 And r > 9 And r < x Then '当输入新规格时自动调取单价
qty = Target.Offset(0, 1).Value ' 出货数量
unitPrice = 0
' 使用Find方法查找规格，这比循环更快
Set searchResult = wsSheet2.Columns(4).Find(searchValue)
If Not searchResult Is Nothing Then
unitPrice = Application.Round(searchResult.Offset(0, 8).Value, 1)
Else
' 如果未找到，可以处理错误或跳过
End If
' 应用折扣（如果需要）
If c = 4 Then
If qty >= 1000 Then
discount = 0.98
ElseIf qty >= 500 Then
discount = 0.99
Else
discount = 1
End If
unitPrice = Application.Round(unitPrice * discount, 2)
End If
Target.Offset(0, 2).Value = unitPrice
End If
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

复制代码

bj917 · 发表于 2024-3-8 10:45

VBA通常在程序开始加两句：
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
在结尾处再恢复：
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

半百 · 发表于 2024-3-8 11:17

当然，最好用数组

Enocheasty · 发表于 2024-3-8 11:21

luketools 发表于 2024-3-8 09:28
没有排序，如果排序的话怎么写

大概的思路就是，假如N个数据已经升序排序，取I=[log2(N)],取n=2^I作为记录位置，每次循环I-1后每次以2^I作为步长进行循环，直至I<0，结束循环
如果数据源(n)大于要查询的数据，则n-步长，小于则n+步长。
理论上n次之内可以从2^n次方条数据中找到需要的数据，例如15次之内就能从32768条数据中找到需要的数据。
如果你的数据源本身没有可比较性，就比较麻烦点，如果愿意折腾的话，可以为数据源建立哈希映射，再排序。
查询时，将查询的数据转哈希码，在数据源的哈希表中查找。

wxxydl · 发表于 2024-3-8 11:57

附件没有怎么调试？

		自动登录	找回密码
密码			免费注册

[求助] 代码优化加速