有没有大佬能帮我优化vba代码

txtz · 2025 年2 月 21 日 08:19

Public Sub 优化()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim time_Start As Double '---------提醒耗时
    time_Start = Timer '---------提醒耗时，开始时间

    Dim wkwx As Worksheet, wkxcl As Worksheet, wkzt As Worksheet, wkpr As Worksheet, wkdj As Worksheet
    Dim wkgk As Worksheet, wkhs As Worksheet, wkqg As Worksheet, wkzz As Worksheet, wkwf As Worksheet
    Dim hwx As Long, hgk As Long, hdj As Long, hhs As Long, hxcl As Long, hqg As Long, hzz As Long, hwf As Long
    Dim dxcl As New Dictionary, dqg1 As New Dictionary, dqg2 As New Dictionary, dzz As New Dictionary, dwf As New Dictionary
    Dim arr1 As Variant, arr2 As Variant, arr3 As Variant, arr4 As Variant
    Dim arr As Variant, d As New Dictionary, arr5 As Variant
    Dim i As Long, m As String, n As String, c As String, s As Long, b As Long, bb As Long
    Dim x1 As Long, x2 As Long, dhs As New Dictionary

    Set wkwx = Worksheets("未下订单")
    hwx = wkwx.UsedRange.Rows.Count
    Set wkgk = Worksheets("管控表")
    hgk = wkgk.UsedRange.Rows.Count
    Set wkdj = Worksheets("单阶BOM")
    hdj = wkdj.UsedRange.Rows.Count
    Set wkhs = Worksheets("核算")
    hhs = wkhs.UsedRange.Rows.Count
    Set wkxcl = Worksheets("现存量")
    hxcl = wkxcl.UsedRange.Rows.Count
    Set wkqg = Worksheets("请购单关联")
    hqg = wkqg.UsedRange.Rows.Count
    Set wkzz = Worksheets("在制")
    hzz = wkzz.UsedRange.Rows.Count
    Set wkwf = Worksheets("在制未发")
    hwf = wkwf.UsedRange.Rows.Count

    ' 现存量 字典 dxcl
    arr1 = wkxcl.[A1].CurrentRegion.value
    For i = 3 To UBound(arr1)
        dxcl(arr1(i, 3)) = dxcl(arr1(i, 3)) + arr1(i, 15)
    Next

    ' 请购 字典 dqg1, dqg2
    arr2 = wkqg.[A1].CurrentRegion.value
    For i = 3 To UBound(arr2)
        dqg1(arr2(i, 9)) = dqg1(arr2(i, 9)) + arr2(i, 14)
        dqg2(arr2(i, 9)) = dqg2(arr2(i, 9)) + arr2(i, 17)
    Next

    ' 在制 字典 dzz
    arr3 = wkzz.[A1].CurrentRegion.value
    For i = 3 To UBound(arr3)
        dzz(arr3(i, 2)) = dzz(arr3(i, 2)) + arr3(i, 6)
    Next

    ' 在制未发 字典 dwf
    arr4 = wkwf.[A1].CurrentRegion.value
    For i = 3 To UBound(arr4)
        dwf(arr4(i, 14)) = dwf(arr4(i, 14)) + arr4(i, 22)
    Next

    ' 清空单阶BOM内容
    wkdj.Activate
    ActiveSheet.AutoFilterMode = False
    Rows("2:" & hdj + 1).ClearContents

    ' 将未下订单复制到单阶BOM
    wkwx.Activate
    ActiveSheet.AutoFilterMode = False
    Rows("2:" & hwx).Copy
    wkdj.Activate
    Rows(2).PasteSpecial Paste:=xlPasteValues

    ' 处理单阶BOM
    hdj = wkdj.UsedRange.Rows.Count
    Range("AA3").Formula = "=D3&F3"
    Range("AA3:AA" & hdj).FillDown
    wkdj.Range("A1:AA" & hdj).RemoveDuplicates Columns:=27, Header:=xlYes

    ' 创建字典 d 存储数据
    arr = wkdj.[A1].CurrentRegion.value
    For i = 3 To UBound(arr) - 1
        d(arr(i, 4)) = d(arr(i, 4)) & arr(i, 6) & "@@" & arr(i, 13) / arr(i, 14) & "@@" & arr(i, 7) & "@@" & arr(i, 8) & "@@" & arr(i, 9) & "&&"
    Next

    ' 核算操作
    For y = 1 To 20
        wkhs.Activate
        ActiveSheet.AutoFilterMode = False
        hhs = wkhs.UsedRange.Rows.Count
        x1 = wkhs.Cells(hhs + 2, 1).End(xlUp).Row
        x2 = wkhs.Cells(hhs + 2, 19).End(xlUp).Row

        If x1 > x2 Then
            For b = x2 + 1 To x1
                n = Cells(b, 1)
                Cells(b, 10) = dzz(n)
                Cells(b, 11) = dxcl(n)
                Cells(b, 12) = dqg1(n)
                Cells(b, 13) = dqg2(n)
                Cells(b, 14) = Cells(b, 10) + Cells(b, 11) + Cells(b, 12) + Cells(b, 13)
                Cells(b, 15) = dwf(n)

                ' 更新订单销量字典
                dhs.RemoveAll
                arr5 = wkhs.[A1].CurrentRegion.value
                For bb = 2 To b
                    dhs(arr5(bb, 1)) = dhs(arr5(bb, 1)) + arr5(bb, 4)
                Next
                Cells(b, 19) = dhs(arr5(b, 1)) + Cells(b, 15) + Cells(b, 16) + Cells(b, 17) + Cells(b, 18)

                ' 判断库存需求
                Cells(b, 20) = Cells(b, 14) - Cells(b, 19)
                If Cells(b, 20) < 0 Then
                    If Abs(Cells(b, 20)) > Cells(b, 4) Then
                        Cells(b, 21) = -Cells(b, 4)
                    Else
                        Cells(b, 21) = Cells(b, 20)
                    End If
                Else
                    Cells(b, 21) = 0
                End If
            Next

            ' 处理炸开操作
            For i = x2 + 1 To x1
                m = Cells(i, 1)
                If d.Exists(m) And Cells(i, 20) < 0 And Cells(i, 9) = "自制" Then
                    c = d(m)
                    s = (Len(c) - Len(Replace(c, "&&", ""))) / 2
                    hhs = wkhs.UsedRange.Rows.Count
                    For b = hhs + 1 To hhs + s
                        Dim dataParts() As String
                        dataParts = Split(Split(d(m), "&&")(b - hhs - 1), "@@")
                        Cells(b, 1) = "'" & dataParts(0)
                        Cells(b, 4) = -dataParts(1) * Cells(i, 21)
                        Cells(b, 2) = dataParts(2)
                        Cells(b, 3) = dataParts(3)
                        Cells(b, 9) = dataParts(4)
                        Cells(b, 5) = Cells(i, 5)
                        Cells(b, 6) = Cells(i, 6)
                        Cells(b, 7) = Cells(i, 7)
                        Cells(b, 8) = Cells(i, 8)
                    Next
                End If
            Next
        End If
    Next

    MsgBox "共耗时：" & Format(Timer - time_Start, "#0.00") & " 秒", , "ybb提示" '---------提醒耗时

    Application.Calculation = xlCalculationAutomatic ' 恢复自动计算
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

txtz · 2025 年2 月 21 日 08:20

100行数据运行时间60s

stevessr · 2025 年2 月 21 日 08:22

要不…还是…转AI吧…这是白嫖吧

1263403710 · 2025 年2 月 21 日 08:24

你这个小尾巴好

txtz · 2025 年2 月 21 日 08:25

ai给的代码不行

stevessr · 2025 年2 月 21 日 08:25

拆开来~~呢

txtz · 2025 年2 月 21 日 08:26

我试过o3 o1 deepseek

haruka.moe · 2025 年2 月 21 日 08:27

题外话，感觉用ai把vba转其他开发语言会不会更快一些

txtz · 2025 年2 月 21 日 08:29

因为要操作表格，python尝试过，做不到vba一样效果，代码没有问题，处理大量数据时间很长。

haruka.moe · 2025 年2 月 21 日 08:30

这个就比较麻烦了。

live · 2025 年2 月 21 日 08:33

处理大量数据的大量是有多少? 或者你可以做个示例的文件发上来.可以测试一下

yhp666 · 2025 年2 月 21 日 08:33

佬直接贴给Gemeni试试吧

live · 2025 年2 月 21 日 08:34

txtz · 2025 年2 月 21 日 08:35

处理数据有6k

joeyzhou · 2025 年2 月 21 日 08:35

excel 大量数据不行，转数据库

live · 2025 年2 月 21 日 08:37

数据量其实不算大, 但是如果处理的逻辑复杂的话,可能会耗时比较久. 或者尝试转到数据库处理下看看

user135 · 2025 年2 月 21 日 08:42

6K 数据也算大么? 找个 pandas 直接开撸呗

Pengo · 2025 年2 月 21 日 09:31

建议直接用cursor开搞，我搞excel一般都是让cursor给我写python脚本，之前比对一个10W+的Excel就是cursor帮忙弄出来的。

这是cursor优化后的代码，佬可以试试

优化代码

Public Sub 优化()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim time_Start As Double '---------提醒耗时
    time_Start = Timer '---------提醒耗时，开始时间

    Dim wkwx As Worksheet, wkxcl As Worksheet, wkzt As Worksheet, wkpr As Worksheet, wkdj As Worksheet
    Dim wkgk As Worksheet, wkhs As Worksheet, wkqg As Worksheet, wkzz As Worksheet, wkwf As Worksheet
    Dim hwx As Long, hgk As Long, hdj As Long, hhs As Long, hxcl As Long, hqg As Long, hzz As Long, hwf As Long
    Dim dxcl As New Dictionary, dqg1 As New Dictionary, dqg2 As New Dictionary, dzz As New Dictionary, dwf As New Dictionary
    Dim arr1 As Variant, arr2 As Variant, arr3 As Variant, arr4 As Variant
    Dim arr As Variant, d As New Dictionary, arr5 As Variant
    Dim i As Long, m As String, n As String, c As String, s As Long, b As Long, bb As Long
    Dim x1 As Long, x2 As Long, dhs As New Dictionary

    Set wkwx = Worksheets("未下订单")
    hwx = wkwx.UsedRange.Rows.Count
    Set wkgk = Worksheets("管控表")
    hgk = wkgk.UsedRange.Rows.Count
    Set wkdj = Worksheets("单阶BOM")
    hdj = wkdj.UsedRange.Rows.Count
    Set wkhs = Worksheets("核算")
    hhs = wkhs.UsedRange.Rows.Count
    Set wkxcl = Worksheets("现存量")
    hxcl = wkxcl.UsedRange.Rows.Count
    Set wkqg = Worksheets("请购单关联")
    hqg = wkqg.UsedRange.Rows.Count
    Set wkzz = Worksheets("在制")
    hzz = wkzz.UsedRange.Rows.Count
    Set wkwf = Worksheets("在制未发")
    hwf = wkwf.UsedRange.Rows.Count

    ' 现存量 字典 dxcl
    arr1 = wkxcl.[A1].CurrentRegion.value
    For i = 3 To UBound(arr1)
        dxcl(arr1(i, 3)) = dxcl(arr1(i, 3)) + arr1(i, 15)
    Next

    ' 请购 字典 dqg1, dqg2
    arr2 = wkqg.[A1].CurrentRegion.value
    For i = 3 To UBound(arr2)
        dqg1(arr2(i, 9)) = dqg1(arr2(i, 9)) + arr2(i, 14)
        dqg2(arr2(i, 9)) = dqg2(arr2(i, 9)) + arr2(i, 17)
    Next

    ' 在制 字典 dzz
    arr3 = wkzz.[A1].CurrentRegion.value
    For i = 3 To UBound(arr3)
        dzz(arr3(i, 2)) = dzz(arr3(i, 2)) + arr3(i, 6)
    Next

    ' 在制未发 字典 dwf
    arr4 = wkwf.[A1].CurrentRegion.value
    For i = 3 To UBound(arr4)
        dwf(arr4(i, 14)) = dwf(arr4(i, 14)) + arr4(i, 22)
    Next

    ' 清空单阶BOM内容
    wkdj.Rows("2:" & hdj + 1).ClearContents

    ' 将未下订单复制到单阶BOM
    Rows("2:" & hwx).Copy
    wkdj.Rows(2).PasteSpecial Paste:=xlPasteValues

    ' 处理单阶BOM
    hdj = wkdj.UsedRange.Rows.Count
    Range("AA3").Formula = "=D3&F3"
    Range("AA3:AA" & hdj).FillDown
    wkdj.Range("A1:AA" & hdj).RemoveDuplicates Columns:=27, Header:=xlYes

    ' 创建字典 d 存储数据
    arr = wkdj.[A1].CurrentRegion.value
    For i = 3 To UBound(arr) - 1
        d(arr(i, 4)) = d(arr(i, 4)) & arr(i, 6) & "@@" & arr(i, 13) / arr(i, 14) & "@@" & arr(i, 7) & "@@" & arr(i, 8) & "@@" & arr(i, 9) & "&&"
    Next

    ' 核算操作
    For y = 1 To 20
        hhs = wkhs.UsedRange.Rows.Count
        x1 = wkhs.Cells(hhs + 2, 1).End(xlUp).Row
        x2 = wkhs.Cells(hhs + 2, 19).End(xlUp).Row

        If x1 > x2 Then
            For b = x2 + 1 To x1
                n = Cells(b, 1)
                Cells(b, 10) = dzz(n)
                Cells(b, 11) = dxcl(n)
                Cells(b, 12) = dqg1(n)
                Cells(b, 13) = dqg2(n)
                Cells(b, 14) = Cells(b, 10) + Cells(b, 11) + Cells(b, 12) + Cells(b, 13)
                Cells(b, 15) = dwf(n)

                ' 更新订单销量字典
                dhs.RemoveAll
                arr5 = wkhs.[A1].CurrentRegion.value
                For bb = 2 To b
                    dhs(arr5(bb, 1)) = dhs(arr5(bb, 1)) + arr5(bb, 4)
                Next
                Cells(b, 19) = dhs(arr5(b, 1)) + Cells(b, 15) + Cells(b, 16) + Cells(b, 17) + Cells(b, 18)

                ' 判断库存需求
                Cells(b, 20) = Cells(b, 14) - Cells(b, 19)
                If Cells(b, 20) < 0 Then
                    If Abs(Cells(b, 20)) > Cells(b, 4) Then
                        Cells(b, 21) = -Cells(b, 4)
                    Else
                        Cells(b, 21) = Cells(b, 20)
                    End If
                Else
                    Cells(b, 21) = 0
                End If
            Next

            ' 处理炸开操作
            For i = x2 + 1 To x1
                m = Cells(i, 1)
                If d.Exists(m) And Cells(i, 20) < 0 And Cells(i, 9) = "自制" Then
                    c = d(m)
                    s = (Len(c) - Len(Replace(c, "&&", ""))) / 2
                    hhs = wkhs.UsedRange.Rows.Count
                    For b = hhs + 1 To hhs + s
                        Dim dataParts() As String
                        dataParts = Split(Split(d(m), "&&")(b - hhs - 1), "@@")
                        Cells(b, 1) = "'" & dataParts(0)
                        Cells(b, 4) = -dataParts(1) * Cells(i, 21)
                        Cells(b, 2) = dataParts(2)
                        Cells(b, 3) = dataParts(3)
                        Cells(b, 9) = dataParts(4)
                        Cells(b, 5) = Cells(i, 5)
                        Cells(b, 6) = Cells(i, 6)
                        Cells(b, 7) = Cells(i, 7)
                        Cells(b, 8) = Cells(i, 8)
                    Next
                End If
            Next
        End If
    Next

    MsgBox "共耗时：" & Format(Timer - time_Start, "#0.00") & " 秒", , "ybb提示" '---------提醒耗时

    Application.Calculation = xlCalculationAutomatic ' 恢复自动计算
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Black_L · 2025 年2 月 21 日 10:10

实在不行那就只有转数据库里处理了

baipiaodang · 2025 年2 月 21 日 10:59

让ai启动吧

话题		回复	浏览量
Excel中两列数据自动对比，有不一致的筛选出来有办法操作吗？开发调优快问快答	26	237	2025 年3 月 24 日
哪个ai能干好这个表格填写的任务？开发调优人工智能	25	558	2025 年3 月 28 日
Excel表标序号，如果几千行下拉很慢怎么办？开发调优快问快答	33	310	2025 年3 月 24 日
AutoHotkey中的类名在不同的电脑中不一致开发调优快问快答	2	171	2025 年3 月 31 日

有没有大佬能帮我优化vba代码

相关话题