保存和判断的信息量大，能否提高保存速度的解决方案.

天真无鞋

请教老师附件文件保存按钮能否提高保存速度，有一定的复杂度，详见附件
1，涂颜色单元格的信息都需要保存到Audit Log QA list里面，从W列开始按单元格对应信息保存，
2、A3单元格输入批号，自动获取谢谢，B5单元格C5单元格需要操作员录入。
3、需判断，当B5、C5、A9、B9、C9、D9、E9、F9单元格无任何谢谢时无法保存；
4、需判断A17\B17\C17\D17\E17\F17\G17\A19\B19\C19\D19\E19\F19\G19\A21\B21\C21\D21,(涂绿色单元格）所有单元格都为空时无法保存，只要有一个单元格或者多个单元格有任意值允许保存；
5、其他涂颜色保存单元格无法判断‘
6、当保存到Audit Log QA list表格里面，如果批号已保存提示"批号已保存"，如果没有对应的批号”提示无批号“。


Sub gx()
    'FQC检验录入
    If Len(Sheet4.Range("b5")) * Len(Sheet4.Range("c5")) * Len(Sheet4.Range("a9")) * Len(Sheet4.Range("b9")) * Len(Sheet4.Range("d9")) * Len(Sheet4.Range("c9")) * Len(Sheet4.Range("e9")) * Len(Sheet4.Range("f9")) = 0 Then
        MsgBox "Data is incomplete"
        Exit Sub
    End If
    Dim gg As Long
    gg = 0
    Dim gzb1 As Worksheet
    Dim gzb2 As Worksheet
    Set gzb2 = ThisWorkbook.Worksheets("Audit Log QA list")
    Set gzb1 = ThisWorkbook.Worksheets("FQC inspection")       '定义工作表
    han = gzb2.Range("a1").End(4).Row + 1                      '确定最后一行行数
    For 行 = 1 To han                                           '循环判断是否重复
        If InStr(gzb2.Cells(行, "c"), gzb1.Cells(3, "a")) Then  '判断是否重复,是则退出程序
            If gzb2.Cells(行, "w") <> "" Then
                MsgBox "Repeat entry"
   
                GoTo XY:
            Else
                With gzb2
                    '.Cells(han, 1) = gzb2.Cells(han - 1, 1) + 1
                    .Cells(行, 3) = gzb1.Range("a3")
                    .Cells(行, "w") = gzb1.Range("a7")
                    .Cells(行, "x") = gzb1.Range("b7")
                    .Cells(行, "y") = gzb1.Range("c7")
                    .Cells(行, "z") = gzb1.Range("d7")
                    .Cells(行, "aa") = gzb1.Range("e7")
                    .Cells(行, "ab") = gzb1.Range("f7")
                    .Cells(行, "ac") = gzb1.Range("g7")
                    .Cells(行, "ad") = gzb1.Range("a9")
                    .Cells(行, "ae") = gzb1.Range("b9")
                    .Cells(行, "af") = gzb1.Range("c9")
                    .Cells(行, "ag") = gzb1.Range("d9")
                    .Cells(行, "ah") = gzb1.Range("e9")
                    .Cells(行, "ai") = gzb1.Range("f9")
                    .Cells(行, "aj") = gzb1.Range("a12")
                    .Cells(行, "ak") = gzb1.Range("b12")
                    .Cells(行, "al") = gzb1.Range("c12")
                    .Cells(行, "am") = gzb1.Range("d12")
                    .Cells(行, "an") = gzb1.Range("e12")
                    .Cells(行, "ao") = gzb1.Range("f12")
                    .Cells(行, "ap") = gzb1.Range("g12")
                    .Cells(行, "aq") = gzb1.Range("a14")
                    .Cells(行, "ar") = gzb1.Range("b14")
                    .Cells(行, "as") = gzb1.Range("a17")
                    .Cells(行, "at") = gzb1.Range("b17")
                    .Cells(行, "au") = gzb1.Range("c17")
                    .Cells(行, "av") = gzb1.Range("d17")
                    .Cells(行, "aw") = gzb1.Range("e17")
                    .Cells(行, "ax") = gzb1.Range("f17")
                    .Cells(行, "ay") = gzb1.Range("g17")
                    .Cells(行, "az") = gzb1.Range("a19")
                    .Cells(行, "ba") = gzb1.Range("b19")
                    .Cells(行, "bb") = gzb1.Range("c19")
                    .Cells(行, "bc") = gzb1.Range("d19")
                    .Cells(行, "bd") = gzb1.Range("e19")
                    .Cells(行, "be") = gzb1.Range("f19")
                    .Cells(行, "bf") = gzb1.Range("g19")
                    .Cells(行, "bg") = gzb1.Range("a21")
                    .Cells(行, "bh") = gzb1.Range("b21")
                    .Cells(行, "bi") = gzb1.Range("c21")
                    .Cells(行, "bj") = gzb1.Range("d21")
                    .Cells(行, "bn") = gzb1.Range("b5")
                    .Cells(行, "bo") = gzb1.Range("c5")
                    .Cells(行, "bp") = gzb1.Range("d5")
                End With
                ActiveWorkbook.Save
                MsgBox "OK"
            End If
        Else
            gg = gg + 1
        End If
    Next
XY:
    If gg = han Then
        MsgBox "no lot number"
    End If
    Range("A3").ClearContents
    Range("B5").ClearContents
    Range("C5").ClearContents
    Range("D5").ClearContents
    Range("A12").ClearContents
    Range("B12").ClearContents
    Range("C12").ClearContents
    Range("D12").ClearContents
    Range("E12").ClearContents
    Range("F12").ClearContents
    Range("G12").ClearContents
    Range("A14").ClearContents
    Range("B14").ClearContents
End Sub

hlxue

建议用数组，这样快很多的。

天真无鞋

hlxue 发表于 2024-5-12 18:19
建议用数组，这样快很多的。

不会，如果能帮忙，有业余的时间帮忙看看，谢谢！

山菊花

前一段连续赋值代码可这样写：
                    .Cells(行, 3) = gzb1.Range("a3")
                    .Cells(行, "w").Resize(1, 7).Value = gzb1.Range("a7").Resize(1, 7).Value
                    .Cells(行, "ad").Resize(1, 6).Value = gzb1.Range("a9").Resize(1, 6).Value
                    .Cells(行, "aj").Resize(1, 7).Value = gzb1.Range("a12").Resize(1, 7).Value
                    .Cells(行, "aq").Resize(1, 2).Value = gzb1.Range("a14").Resize(1, 2).Value
                    .Cells(行, "as").Resize(1, 7).Value = gzb1.Range("a17").Resize(1, 7).Value
                    .Cells(行, "az").Resize(1, 7).Value = gzb1.Range("a19").Resize(1, 7).Value
                    .Cells(行, "bg").Resize(1, 4).Value = gzb1.Range("a21").Resize(1, 4).Value
                    .Cells(行, "bn").Resize(1, 3).Value = gzb1.Range("b5").Resize(1, 3).Value

后面连续清除的代码可以这样写：
    Range("A3,B5:D5,A12:G12,A14:B14").ClearContents

天真无鞋

山菊花 发表于 2024-5-12 20:41
前一段连续赋值代码可这样写：
                    .Cells(行, 3) = gzb1.Range("a3")
                 ...

谢谢老师

lln0618

加入以下代码可以提高运行速度：
开头：
Application.ScreenUpdating = False '关闭刷新
Application.Calculation = xlManual '禁用自动计算

结尾：
Application.ScreenUpdating = True  '恢复刷新
Application.Calculation = xlAutomatic '恢复自动计算

天真无鞋

lln0618 发表于 2024-5-13 16:12
加入以下代码可以提高运行速度：
开头：
Application.ScreenUpdating = False '关闭刷新

谢谢老师

全党

If Len(Sheet4.Range("b5")) * Len(Sheet4.Range("c5")) * Len(Sheet4.Range("a9")) * Len(Sheet4.Range("b9")) * Len(Sheet4.Range("d9")) * Len(Sheet4.Range("c9")) * Len(Sheet4.Range("e9")) * Len(Sheet4.Range("f9")) = 0 Then
这一段，使用with，因为多次判断引用。

天真无鞋

全党 发表于 2024-5-14 09:57
If Len(Sheet4.Range("b5")) * Len(Sheet4.Range("c5")) * Len(Sheet4.Range("a9")) * Len(Sheet4.Range("b ...

是，判断的目的就是当单元格有空的情况下不允许保存。

fanyoulin

天真无鞋 发表于 2024-5-14 11:23
是，判断的目的就是当单元格有空的情况下不允许保存。

我相当认真的看了你的代码，仅对“保存”这个局部来说，你的代码有两个问题：
1、关于Private Sub Worksheet_Change(ByVal Target As Range)
     If Not Intersect(Target, Me.Range("A1:AA1000")) Is Nothing Then '自动保存
        ThisWorkbook.Save
     End If
     End Sub
    每更新一次工作表，哪怕只有一个单元格的更新，都要保存一次文件，明显是有问题的；


2、关于重复查询，最好使用字典，但这个问题比第一个问题相比较，对目前的数据量来说，对速度的影响倒还是其次，数据量越大影响越明显。当数据量有几千条的时候会明显感受到速度的差异；
    字典代码大致可以写成下面截图的样子，其中arr数组的那两行是不需要的，我是想测试下用数组是否会改进速度；