注册 登录
编程论坛 → VB6论坛

请老师帮我提速一下程序

vbcaonia 发布于 2022-12-01 22:56， 4023 次点击

题意是：
1、access数据库中有二个表：表1（数据）、表2（条件）；表1每行数据中相邻二个数据空1格，表2每行以等号为界，等号

右边数据中相邻二个数据空1格，等号左边数据区间表示包含右边的数据个数即：1到3个。

2、表2的数据每15行一组在表1中查找，将同时符合每组15行条件的数据提取到VSFlexGrid1

表1（数据）形式：
1 2 3 7 14 15 35
1 2 3 7 17 31 36
1 2 3 7 31 33 35
1 2 3 8 14 22 30
1 2 3 8 18 25 26

表2（条件）形式：
1-3=31 12 24 7 23 3 10
1-1=35 11 16 15 17 26 3
1-1=34 31 27 24 17 33 10
1-2=28 12 6 36 7 26 33


程序运行较慢，请老师帮我修改一下程序已达到快速运行的效果，谢谢！！！


Private Sub Command1_Click() '条件过滤
t = Timer
     Dim arr(), drr(), crr(), tjrr(), tt, gx, tj, dn, pd As Long, brr, krr, ii As Long, kk As Long
    Dim Cnn As New adodb.Connection
    Dim Rst As New adodb.Recordset
    Dim Rs As New adodb.Recordset
    Dim SQL As String, myTable As String
    Set d = CreateObject("scripting.dictionary")
    Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=F:\数据条件源.mdb;Persist Security Info=False"
    SQL = "Select * from " & "表1"
    Rst.Open SQL, Cnn, adOpenKeyset, adLockOptimistic
    ReDim crr(1 To Rst.RecordCount, 1 To 1)
    For ii = 1 To Rst.RecordCount
        crr(ii, 1) = Rst.Fields(0)
        Rst.MoveNext
    Next ii
   
    SQL1 = "Select * from " & "表2"
    Rs.Open SQL1, Cnn, adOpenKeyset, adLockOptimistic
    ReDim arr(1 To Rs.RecordCount, 1 To 1)
    For kk = 1 To Rs.RecordCount
        arr(kk, 1) = Rs.Fields(0)
        Rs.MoveNext
    Next kk


tj = 15
ReDim tjrr(1 To tj, 1 To 12)
For i = 1 To UBound(arr)
    n = n + 1
    tt = Split(arr(i, 1), "=")
    krr = Split(Trim(tt(1)), " ")
    gs = Split(tt(0), "-")
    tjrr(n, 1) = Val(gs(0))
    tjrr(n, 2) = Val(gs(1))
    For j = 0 To UBound(krr)
        tjrr(n, 3 + j) = krr(j)
Next

    If n = tj Then
        For m = 1 To UBound(crr)
            brr = Split(crr(m, 1), " ")
            For k = 1 To tj
                pd = 0
                For l = 3 To UBound(krr) + 3
                    d(tjrr(k, l)) = m
                Next
                For l = 0 To UBound(brr)
                    If d.Exists(brr(l)) Then pd = pd + 1
                Next
                d.RemoveAll
                If pd < CSng(tjrr(k, 1)) Or pd > CSng(tjrr(k, 2)) Then Exit For
            Next
            If k = tj + 1 Then dn = dn + 1: VSFlexGrid1.TextMatrix(dn, 0) = crr(m, 1)
        Next
        n = 0
    End If
Next
MsgBox Timer - t
End Sub
30 回复
#2
约定的童话2022-12-02 14:38
数据库,SQL，数组，字典，能上的都上了，再慢就换电脑吧...
#3
vbcaonia2022-12-02 16:31
回复 2楼 约定的童话
这运算速度比在vba上慢一半
#4
mrexcel2022-12-03 13:35
代码优化余地很大，上个附件吧。你的数据规模没必要上ACCESS,EXCEL足够了
#5
jklqwe1112022-12-03 17:44
应该解释一下什么样的数据叫符号条件
#6
yuma2022-12-04 09:21
只有本站会员才能查看附件，请 登录
#7
风吹过b2022-12-04 11:47
可以转换为 SQL 命令，直接执行查询吗？
SQL命令是在 SQL引擎中执行，比我们代码访问所有的数据，然后一个一个的筛查要快的多，参考为什么要用 存储过程。
--------------
终极优化就是上 SQL，如 MSSQL ，然后写存储过程。
#8
vbcaonia2022-12-05 20:34
回复 4楼 mrexcel
数据为800万行，条件为14万行
#9
vbcaonia2022-12-05 20:57
回复 7楼 风吹过b
可以
#10
vbcaonia2022-12-06 08:50
回复 4楼 mrexcel
只有本站会员才能查看附件，请 登录
#11
vbcaonia2022-12-06 10:07
回复 7楼 风吹过b
麻烦 版主将程序转换为 SQL 命令，直接执行查询，谢谢！

只有本站会员才能查看附件，请 登录
#12
mrexcel2022-12-06 21:31
你的MDB的两个表都只有一个字段？160万行一个字段？
#13
mrexcel2022-12-06 21:36
表2是个空表
#14
vbcaonia2022-12-06 21:50
回复 13楼 mrexcel
把数据导入就可以了，表1、表2的数据不是固定的，随需要导入数据
#15
vbcaonia2022-12-06 22:05
回复 12楼 mrexcel
对，2个表都是一个字段，相当于excel的a、b二列然后b列条件在a列数据查找，其结果放在c列。
#16
jklqwe1112022-12-06 22:30
从文本文件直接查找，只适用于数据在1-60之间
只有本站会员才能查看附件，请 登录
#17
vbcaonia2022-12-06 22:53
回复 16楼 jklqwe111
谢谢老师！！！
我先消化一下...
#18
vbcaonia2022-12-07 15:52
回复 16楼 jklqwe111
老师你好，数据还能增加吗，1-60没有用呀
#19
jklqwe1112022-12-07 17:03
实际的数据范围是多少
#20
vbcaonia2022-12-07 18:55
回复 19楼 jklqwe111
实际数据为840万条左右,条件为5万条左右
#21
jklqwe1112022-12-07 19:48
你理解错了，我不是说数据的规模多大，是说数据值的范围，比如 1 25 31 33 36 在1--36 范围内，看你给出的数据，最大不超过36，实际数据是不是也这样，最大值不能大于60就可以使用
#22
vbcaonia2022-12-07 23:00
回复 21楼 jklqwe111
老师你好，我把b1数据加到5000行，程序显示 （dataStr(dn) = str黄色）下标越界，麻烦看看问题所在，谢谢！！！

只有本站会员才能查看附件，请 登录
#23
jklqwe1112022-12-07 23:57
重新修改了一下，再试试
只有本站会员才能查看附件，请 登录
#24
vbcaonia2022-12-08 11:36
回复 23楼 jklqwe111
老师你好，经测试速度快了很多，谢谢！！！
#25
vbcaonia2022-12-08 23:28
回复 21楼 jklqwe111
老师你好，测试数值时，还真是不能大于60，由于我的水平有限，想改到80没有成功，请老师指点，谢谢！
#26
jklqwe1112022-12-09 19:51
数据最大值到底有多大
#27
vbcaonia2022-12-09 21:43
回复 26楼 jklqwe111
最大值等于80，谢谢！！！
#28
jklqwe1112022-12-09 23:01
如果不大于90，改一下还是可以的，但效率肯定要下降，如果数值再大，这种方法就不适合了，以下是代码，你试一下
程序代码：


Option Explicit
Sub getmask(mk() As Long)

  Dim i As Long

  ReDim mk(1 To 30)
  mk(1) = 1
  For i = 2 To 30
  
     mk(i) = mk(i - 1) * 2
  
  Next

End Sub
Private Function number1(ByVal a As Long) As Long
  
  number1 = 0
  
  Do While a <> 0
   
    number1 = number1 + 1
    a = a And (a - 1)
  Loop
     
End Function

Private Sub Command1_Click()

    Dim mask() As Long
    Dim t As Double
    Dim data() As Long
    Dim dataStr() As String
    Dim dn As Long
    Dim n As Long
    Dim tn As Long
    Dim tj() As Long
    Dim str As String
    Dim add As Long
    Dim k As Long
    Dim i As Long
    Dim j As Long
    Dim tmp As Long
    Dim tm As Long
     
     
     t = Timer
     add = 300
         
     getmask mask

     dn = 0
     ReDim dataStr(add - 1)
     ReDim data(2, add - 1)
   
     Open App.Path & "\b1.txt" For Input As #1
   
   
     Do While Not EOF(1)
     
        Line Input #1, str
        
        If dn > UBound(dataStr) Then
           ReDim Preserve dataStr(UBound(dataStr) + add)
           ReDim Preserve data(2, UBound(data, 2) + add)
        End If
        dataStr(dn) = str
        
        k = 1
      
        Do While 1
        
           n = InStr(k, str, " ")
           If n <> 0 Then
              tmp = Val(Mid(str, k, n - k))
              If tmp <= 30 Then
                  data(0, dn) = data(0, dn) Or mask(tmp)
              ElseIf tmp >= 31 And tmp <= 60 Then
                  data(1, dn) = data(1, dn) Or mask(tmp - 30)
              ElseIf tmp >= 61 And tmp <= 90 Then
                  data(2, dn) = data(2, dn) Or mask(tmp - 60)
              End If
            Else
              tmp = Val(Mid(str, k, Len(str)))
              If tmp > 0 And tmp <= 30 Then
                  data(0, dn) = data(0, dn) Or mask(tmp)
              ElseIf tmp >= 31 And tmp <= 60 Then
                  data(1, dn) = data(1, dn) Or mask(tmp - 30)
              ElseIf tmp >= 61 And tmp <= 90 Then
                  data(2, dn) = data(2, dn) Or mask(tmp - 60)
            
              End If
              Exit Do
            End If
           
            k = n + 1
            
         Loop
         dn = dn + 1
     Loop
     Close #1

 
     tm = Val(Text1)
     
     tn = 0
   
     ReDim tj(4, tm - 1)
     
     Open App.Path & "\b2.txt" For Input As #1
   
   
     Do While Not EOF(1)
     
        Line Input #1, str
        
        k = 1
         
        n = InStr(k, str, "-")
         
        tmp = Val(Mid(str, 1, n - 1))
        tj(3, tn) = tmp
         
        k = n + 1
        n = InStr(k, str, "=")
         
        tmp = Val(Mid(str, k, n - 1))
        tj(4, tn) = tmp
        k = n + 1
        Do While 1
        
           n = InStr(k, str, " ")
           If n <> 0 Then
              tmp = Val(Mid(str, k, n - k))
              If tmp <= 30 Then
                  tj(0, tn) = tj(0, tn) Or mask(tmp)
              ElseIf tmp >= 31 And tmp <= 60 Then
                  tj(1, tn) = tj(1, tn) Or mask(tmp - 30)
              ElseIf tmp >= 61 And tmp <= 90 Then
                  tj(2, tn) = tj(2, tn) Or mask(tmp - 60)
              End If
            Else
              tmp = Val(Mid(str, k, Len(str)))
              If tmp > 0 And tmp <= 30 Then
                  tj(0, tn) = tj(0, tn) Or mask(tmp)
              ElseIf tmp >= 31 And tmp <= 60 Then
                  tj(1, tn) = tj(1, tn) Or mask(tmp - 30)
              ElseIf tmp >= 61 And tmp <= 90 Then
                  tj(2, tn) = tj(2, tn) Or mask(tmp - 60)
              End If
              Exit Do
            End If
           
            k = n + 1
         Loop
         
        tn = tn + 1
        If tn = tm Then
           For i = 0 To dn - 1
                For j = 0 To tn - 1
                    tmp = number1(data(0, i) And tj(0, j)) + number1(data(1, i) And tj(1, j)) + number1(data(2, i) And tj(2, j))
                    If tmp < tj(3, j) Or tmp > tj(4, j) Then
                  
                      Exit For
            
                    End If
                    
               Next
           If j = tn Then Me.List1.AddItem dataStr(i)
           
           Next
           
           tn = 0
            ReDim tj(4, tm - 1)
        End If
               
   Loop
   
  Close #1
   
  Text2 = Timer - t
  Text3 = Me.List1.ListCount
  Text4 = Me.List2.ListCount
End Sub
#29
vbcaonia2022-12-10 08:35
回复 28楼 jklqwe111
谢谢指点！！！
#30
vbcaonia2022-12-24 18:52
回复 28楼 jklqwe111
老师你好：
查找按钮中的程序，我想将原:
Open App.Path & "\b1.txt" For Input As #1的数据来源改为文本框text4.text
Open App.Path & "\b2.txt" For Input As #1的数据来源改为文本框text5.text
运行时越界，烦请老师看看，谢谢！！！
问题：
data(1, dn) = data(1, dn) Or mask(tmp - 30)



只有本站会员才能查看附件，请 登录
#31
vbcaonia2023-03-04 21:46
回复 28楼 jklqwe111
老师这个程序放在vbnet中时，这一句： getmask mask 中会显示：变量“mask”在赋值前被使用。可能会在运行时导致空引用异常

能修改吗，谢谢！
1
©2024, BCCN.NET
电脑版