这个查询代码还有可以优化吗？感觉输入数据时候一卡一卡的。

jsjysqr

Sub 查询数据()
Dim d As Object, arr, brr, crr, hrr, i%, j, k%, ar, br, cr, hr
Set d = CreateObject("scripting.dictionary")
    d.CompareMode = vbTextCompare
Set a = CreateObject("scripting.dictionary")
    a.CompareMode = vbTextCompare
    Application.ScreenUpdating = False
    Windows("仓库存储软件2024年09月05日.xlsm").Activate
    ar = Sheets("数据导入页面").Range("aa1").CurrentRegion '出入明细
    br = Sheets("数据库").Range("a4").CurrentRegion '数据库明细
  ReDim arr(1 To UBound(ar, 1), 1 To 4) '出入明细
    For i = 1 To UBound(ar)
     If Not d.exists(CStr(ar(i, 1))) Then
       x = x + 1
      d(CStr(ar(i, 1))) = x
      arr(x, 1) = ar(i, 1)
      arr(x, 2) = ar(i, 2)
      arr(x, 3) = ar(i, 4)
      arr(x, 4) = ar(i, 5)
     End If
    Next

   x = 0
   ReDim brr(1 To UBound(br, 1), 1 To 4) '数据库明细
    For i = 1 To UBound(br)
     x = x + 1
      brr(x, 1) = br(i, 1)
      brr(x, 2) = br(i, 2)
      brr(x, 3) = br(i, 4)
      brr(x, 4) = br(i, 6)
    Next

k = 0
x = 0

ReDim crr(1 To UBound(ar), 1 To 9)
    For i = 2 To UBound(ar)
        If Not a.exists(CStr(ar(i, 1))) Then
        k = k + 1
        a(CStr(ar(i, 1))) = k
        crr(k, 1) = ar(i, 1)
        crr(k, 2) = ar(i, 2)
        crr(k, 3) = ar(i, 3)
        crr(k, 4) = ar(i, 4)
        crr(k, 5) = ar(i, 5)
        crr(k, 6) = ar(i, 6)
        crr(k, 7) = ar(i, 7)
        crr(k, 8) = ar(i, 8)
        crr(k, 9) = ar(i, 12)
        Else
        j = a(CStr(ar(i, 1)))
        crr(j, 7) = crr(j, 7) + Val(ar(i, 7))
        crr(j, 6) = crr(j, 6) + Val(ar(i, 6))
        crr(j, 9) = ar(i, 12)

        End If
    Next

ReDim cr(1 To UBound(crr), 1 To 10)
    For i = 1 To UBound(crr)
      If crr(i, 1) <> "" Then '如果没有字典中的数据，那就按顺序列表列举
        x = x + 1
        cr(x, 1) = crr(i, 1)
        cr(x, 2) = crr(i, 2)
        cr(x, 3) = crr(i, 3)
        cr(x, 4) = crr(i, 4)
        cr(x, 5) = crr(i, 5)
       If crr(i, 6) <> "入库数量" Then
        cr(x, 6) = crr(i, 6) - crr(i, 7)
       End If
        cr(x, 7) = crr(i, 9)
      End If
    Next
If Me.OptionButton2 = False And Me.OptionButton1 = False Then
MsgBox ("请选择数据类型")
Exit Sub
UserForm4.Show 0.1
End If
x = 0
If Me.OptionButton2 = True Then
  ReDim hr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
  For i = 1 To UBound(arr)
   x = x + 1
     For ii = 1 To UBound(arr, 2)
       hr(x, ii) = arr(i, ii)
     Next
   Next
End If

  If Me.OptionButton1 = True Then
  ReDim hr(1 To UBound(brr, 1), 1 To UBound(brr, 2))
  For i = 1 To UBound(brr)
   x = x + 1
     For ii = 1 To UBound(brr, 2)
       hr(x, ii) = brr(i, ii)
     Next
   Next
End If
    Application.ScreenUpdating = True

'------------------------------------------------------------------------------------------------------------------------------------------------
x = 0
ReDim hrr(1 To UBound(hr), 1 To UBound(hr, 2))

查询 = Me.TextBox1.text

For i = 1 To UBound(hr)

C1 = CStr(hr(i, 1)) Like "*" & 查询 & "*"

C2 = CStr(hr(i, 2)) Like "*" & 查询 & "*"

C3 = CStr(hr(i, 3)) Like "*" & 查询 & "*"

C4 = hr(i, 4) Like "*" & 查询 & "*"

If hr(i, 1) = "物品号" Or C1 Or C2 Or C3 Or C4 Then

     x = x + 1

     For j = 1 To UBound(hr, 2)

         hrr(x, j) = hr(i, j)

     Next

  End If

  Next

  If x > 0 Then

  ReDim hr(1 To x, 1 To 4)

  For i = 1 To x

    For j = 1 To 4

     hr(i, j) = hrr(i, j)

     Next

  Next

With Me.ListBox2
         .List = hr

End With
Label5.Caption = "共找到 " & UBound(hr) - 1 & " 条记录"
End If

End Sub

ykcbf1100

代码是要根据附件的实际情况来看的，光有代码有啥用啊。
你想解决问题，还是上传一个附件吧。

约定的童话

建议把数据存入Access数据库，利用SQL语句实现毫秒级查询