求助：多条件组合查询

mclxxy

VBA小白求优化下面的代码：
Sub dtjzhcx() 'Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False '关闭工作表事件
    Sheets("发货查询").Range("a4:h65536").Clear '清空原有的数据
Dim ar, br, dr, gr, nr, pr, qr, vr, ok, arr, crr, i, m, n, x, a&, MyKey1, MyKey2, MyKey3, MyKey4, y, b, d
   a = Sheets("发货明细").[d65536].End(xlUp).Row
MyKey1 = Sheets("发货查询").Range("k3")
MyKey2 = Sheets("发货查询").Range("l3")
MyKey3 = Sheets("发货查询").Range("m3")
MyKey4 = Sheets("发货查询").Range("n3")
    Application.ScreenUpdating = False '关闭屏幕刷新
   ar = Sheets("发货明细").Range("a3:a" & a)
   br = Sheets("发货明细").Range("b3:b" & a)
   dr = Sheets("发货明细").Range("d3:d" & a)
   gr = Sheets("发货明细").Range("g3:g" & a)
   nr = Sheets("发货明细").Range("n3:n" & a)
   pr = Sheets("发货明细").Range("p3:p" & a)
   qr = Sheets("发货明细").Range("q3:q" & a)
   vr = Sheets("发货明细").Range("v3:v" & a)
   ReDim arr(1 To a - 2, 1 To 8) '重定义a-2行8列 Preserve
   For Each ok In Array(ar, br, dr, gr, nr, pr, qr, vr)
       n = n + 1
       x = UBound(ok)
       For i = 1 To x
        arr(i, n) = ok(i, 1)
       Next i
       If m < x Then m = x
   Next
   If (MyKey1 = "") And (MyKey2 = "") And (MyKey3 = "") And (MyKey3 = "") Then
   'Sheets("发货查询").Range("a4:h65536").Clear
   Sheets("发货查询").Range("a4").Resize(m, n) = arr
   Sheets("发货查询").Range("a4").Resize(m, n).Borders.LineStyle = 1
   GoTo qb
   Else
   ReDim crr(1 To UBound(arr), 1 To 8)
    For d = 1 To UBound(arr)
     If (MyKey1 = "" Or arr(d, 3) = MyKey1) _
     And (MyKey2 = "" Or arr(d, 2) >= MyKey2) _
     And (MyKey3 = "" Or arr(d, 2) <= MyKey3) _
     And (MyKey4 = "" Or arr(d, 4) = MyKey4) Then
     y = y + 1
       For b = 1 To 8
        crr(y, b) = arr(d, b)
       Next b
     End If
    Next d
   End If
If y = "" Then GoTo ts
   Application.ScreenUpdating = True '打开屏幕刷新
   Sheets("发货查询").Range("a4").Resize(y, b - 1) = crr '这里的b为什么是9？
   Sheets("发货查询").Range("a4").Resize(y, b - 1).Borders.LineStyle = 1
qb:
   With Sheets("发货查询").Range("a4:h65536").Font
    .Name = "Times New Roman"
    .Size = 10
    '.Bold = True
   End With
  'Worksheets("发货查询").Columns("A:H").EntireColumn.AutoFit '数据表上从 A 列到 H 列的列宽调整为最合适的值
  Worksheets("发货查询").Columns("A:G").EntireColumn.HorizontalAlignment = xlCenter '左右居中
       '.VerticalAlignment = xlCenter '上下居中
       '.WrapText = False
      ' .Orientation = 0
       '.AddIndent = False
      ' .IndentLevel = 0
      ' .ShrinkToFit = False
       '.ReadingOrder = xlContext
      ' .MergeCells = False
    Application.EnableEvents = True '打开工作表事件
      Exit Sub
ts:
    Application.EnableEvents = True
MsgBox "没有符合条件的数据" & MyKey1 & MyKey2 & MyKey3 & MyKey4 & "换个条件试试!", 64, "温馨提示"
End Sub
附件中，在数据多时运行－（提取产品名称）和（提取代理商名称）模块后保存时数据有效性出错，

这是东拼西凑出来的代码，在运行查询后，文件增大，不知道是什么原因？

mclxxy

第一次开新帖，祝各位版主节日快乐！

duquancai

mclxxy 发表于 2018-6-18 19:21
第一次开新帖，祝各位版主节日快乐！

对你的需求你啥都不说！让人看你的代码，是这意思吗？

mclxxy

duquancai 发表于 2018-6-18 19:24
对你的需求你啥都不说！让人看你的代码，是这意思吗？

代码后面有情况说明呀，不好意思，需求没有单独放在一起1，优化代码，数据多时也运行快
2，在数据多时运行－（提取产品名称）和（提取代理商名称）模块后保存时数据有效性出错
3，代码中的b的值为什么是9

duquancai

mclxxy 发表于 2018-6-18 19:40
代码后面有情况说明呀不好意思，需求没有单独放在一起1，优化代码，数据多时也运行快
2，在数据多时运行 ...

好的，有空再看，现在看 世界杯了。

mclxxy

duquancai 发表于 2018-6-18 20:02
好的，有空再看，现在看 世界杯了。

先行谢过！
追加一个需求：
发货查询表的序号列能否重新从1开始生成新的序号

mclxxy

帖沉大海，自己顶一下。找到文件增大的原因，不知道怎么改代码