这是悬赏区一个有门槛的VBA结果

stiller

如题，这是我写的悬赏区一个VBA求助的结果，
突然加了门槛不能回贴，所以发在这里，。
尽量写了注释，VBA数据结构好难用。。

[Visual Basic] 纯文本查看 复制代码

Sub 信息匹配()
    Application.ScreenUpdating = False

    outname = "查询表"  '在这里查询

    '设置一些需要的变量
    querystr = Sheets(outname).Range("D2").Value '假设这个是要查找的物料
    Set d1 = CreateObject("Scripting.Dictionary")    '区域字典
    Dim data As New Collection  '总有效数据
    n = 0   '这个是有效的数据量
    
    '读取所有信息
    Sheets("数据合并").Activate
    x = Cells(2, 2).End(xlDown).Row           '总数据表行数
    y = Cells(2, 2).End(xlToRight).Column      '总数据表列数
    t = WorksheetFunction.Transpose(Range(Cells(1, 1), Cells(x, y)).Value) '所有信息 t(列，行)

    Debug.Print "总数据" & UBound(t, 2) & "行，" & UBound(t, 1) & "列"
    Debug.Print "要查找的物料：" & querystr
    
    '初步统计数据，获得：区域字典、有效数据数量
    For i = 2 To UBound(t, 2)    '遍历所有数据行UBound(t, 2)
        '限定物料、限定费用

        'Debug.Print "物料判断：第" & i & "条,物料:" & t(3, i) & "，键:" & t(4, i) & "，值:" & i
        t4i = t(4, i)
        'Debug.Print "键:" & t4i & "，值:" & i
        If t(3, i) = querystr And t(13, i) > 0 Then
            'Debug.Print "物料判断：符合要求_物料:" & t(3, i) & "，键:" & t4i & "，值:" & i
            '将信息存入区域字典 键：区域，值：序号
            
            If d1(t4i) = "" Then    'dict.Exists(t4i)结果不准，原因未知
                d1(t4i) = i
                Debug.Print "新键：" & t4i & ":" & d1(t4i)  'Debug.Print "不存在这个键，" & t4i
            Else
                d1(t4i) = i & "," & d1(t4i)
                Debug.Print "更新键：" & t4i & ":" & d1(t4i)    'Debug.Print "存在这个键，" & t4i
            End If
            n = n + 1
        End If
    Next i
    'Debug.Print "有效数据：" & n & "条"
    '遍历区域字典，序列化并切片
    
    For Each Key In d1.Keys
        'Debug.Print "Key: " & key & ", Value: " & d1(key)
        Dim a As New Collection
        List1 = Split(d1(Key), ",")
        For j = LBound(List1) To UBound(List1)
            a.Add List1(j)
            'Debug.Print "特征序号：" & List1(j)
        Next j
        
        Debug.Print "开始升序排列，集合元素数：" & a.Count
        
        For i = 1 To a.Count - 1
            For j = 1 To a.Count - i
                'Debug.Print j, j + 1
                If CInt(t(13, a(j))) > CInt(t(13, a(j + 1))) Then '交换元素
                    temp = a(j)
                    a.Remove j
                    a.Add temp, after:=j    '用before遇到边界会报错
                    'Debug.Print "要把第" & j & "个跟第" & j + 1 & "个交换位置"
                End If
            Next j
        Next i
        
        'Debug.Print "排序完成了！开始筛选值！" & a.Count
        '这里要判定有几个不同的值，并且限制留几个不同的值

        If a.Count > 2 Then
            ind = 0
            For j = 1 To a.Count - 1
                'Debug.Print CInt(t(13, a(j))) & "-" & CInt(t(13, a(j + 1)))
                If CInt(t(13, a(j))) <> CInt(t(13, a(j + 1))) Then
                    ind = ind + 1
                End If
                If ind > 2 Then
                    icount = j - 1
                    Exit For
                End If
            Next j
        Else
            icount = a.Count
        End If
        
        'Debug.Print icount
        Debug.Print "最终结果输出"
        For i = 1 To icount
            Debug.Print a(i) & "_" & t(13, a(i))
            data.Add a(i)   '更新总的数据集合
        Next i
        Set a = Nothing '销毁集合元素
    Next Key
    
    Debug.Print "有效总数据数：" & data.Count

    '旧数据清除
    Sheets(outname).Activate
    If Cells(9, 1).Value <> "" And Cells(8, 2).Value <> "" Then
        c = Cells(8, 1).End(xlToRight).Column
        r = Cells(8, 1).End(xlDown).Row
        Cells(8, 1).Resize(r - 7, c).Clear
    End If
    '将数据应用到sheet
    For i = 1 To data.Count
        di = data(i)
        For j = 1 To UBound(t, 1)
            Cells(7 + i, j).Value = t(j, di)
        Next j
    Next i

    Cells.AutoFit
    Application.ScreenUpdating = True
End Sub

jyjjf

我知道，他的那个表格设计有问题，查询的结果还和汇总出来的列次序不一样，区域也没提前做成字典表，导致执行效率不高，这类表vba最主要是优化执行速度上面，因为数据量一大，代码写不好就会把时间浪费在循环遍历上面，导致出现结果时卡顿延迟，vba本身执行效率就不高。

xuanmuluck

用vba+sql的速度会不会快点？

szllw

'dict.Exists(t4i)结果不准，原因未知
改成：d1.exists ???