VBA计算一行同时出现2个数的遗漏

laoau138 · 发表于 2016-10-7 22:33

本帖最后由 laoau138 于 2016-10-8 12:07 编辑

VBA计算一行同时出现2个数的遗漏

grf1973 · 发表于 2016-10-8 14:14

Sub grf()
arr = Range("a11:E" & [a65536].End(3).Row): n = UBound(arr)
brr = Range("g11:h" & [g65536].End(3).Row)
ReDim crr(1 To UBound(brr), 1 To 2)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(brr) '以两数为key，以行号相连为item
x1 = brr(i, 1): x2 = brr(i, 2)
x = x1 & "," & x2
For ia = 1 To n
k = 0
For ja = 1 To UBound(arr, 2)
If arr(ia, ja) = x1 Or arr(ia, ja) = x2 Then k = k + 1
Next
If k = 2 Then d(x) = d(x) & "," & ia
Next
Next
For i = 1 To UBound(brr)
x1 = brr(i, 1): x2 = brr(i, 2)
x = x1 & "," & x2
If Not d.exists(x) Then '如果两数在数组中各行都不存在，最大遗漏=最近遗漏=数组行数
crr(i, 1) = n
crr(i, 2) = n
Else
d(x) = 0 & d(x) & "," & n + 1 '加头加尾，以计算最大遗漏
xrr = Split(d(x), ",")
crr(i, 1) = n - xrr(UBound(xrr) - 1) '最近遗漏
tmp = 0
For j = 0 To UBound(xrr) - 1 '从相隔数中取最大值
tmp = IIf(xrr(j + 1) - xrr(j) > tmp, xrr(j + 1) - xrr(j), tmp)
Next
crr(i, 2) = tmp - 1
End If
Next
[k11].Resize(UBound(crr), 2) = crr
End Sub

复制代码

grf1973 · 发表于 2016-10-8 14:15

十分佩服这么复杂的公式能想出来。几十行的代码一个公式搞定，神人也。

laoau138 · 发表于 2016-10-8 16:18

grf1973 发表于 2016-10-8 14:15
十分佩服这么复杂的公式能想出来。几十行的代码一个公式搞定，神人也。

EH论坛函数版块，确实有个高人 wangjguo44

laoau138 · 发表于 2016-10-8 16:19

lzxdy

Sub test()
Dim d(), b(), c()
r = 16
Row = 65
ReDim d(11 To r)
ReDim c(11 To Row, 1 To 2)
a = Range("a11:e" & r)
For i = 11 To r
Set d(i) = CreateObject("scripting.dictionary")
For j = 1 To 5
d(i)(a(i - 10, j)) = ""
Next
Next
For k = 11 To Row
ReDim b(11 To 16)
n = 0
For i = 11 To r
If d(i).Exists(Cells(k, 7).Value) And d(i).Exists(Cells(k, 8).Value) Then
b(i) = 0
n = 0
Else
n = n + 1
b(i) = n
End If
Next
c(k, 1) = n
c(k, 2) = Application.Max(b)
Next
Cells(11, 11).Resize(Row - 10, 2) = c
For i = 11 To r
Set d(i) = Nothing
Next
End Sub

		自动登录	找回密码
密码			注册

[VBA] VBA计算一行同时出现2个数的遗漏

本帖子中包含更多资源

本帖子中包含更多资源

评分