这是悬赏区一个有门槛的VBA结果
如题，这是我写的悬赏区一个VBA求助的结果，突然加了门槛不能回贴，所以发在这里，。
尽量写了注释，VBA数据结构好难用。。
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
我知道，他的那个表格设计有问题，查询的结果还和汇总出来的列次序不一样，区域也没提前做成字典表，导致执行效率不高，这类表vba最主要是优化执行速度上面，因为数据量一大，代码写不好就会把时间浪费在循环遍历上面，导致出现结果时卡顿延迟，vba本身执行效率就不高。 用vba+sql的速度会不会快点？ 'dict.Exists(t4i)结果不准，原因未知
改成：d1.exists ???
页:
[1]