统计一行中各数字出现次数的和

新农夫

我再写净赚100万看看要不要审核！

新农夫

xiangbaoan 发表于 2018-10-3 13:06
Sub test()'没10W+数据测试
Dim s As New Collection, ar(), br, lr&, r&, c%, n&, i%, j%, k%
lr = Cell ...

您好！再麻烦您一下！
例如：16161不要算数，25555也不要算数（您的代码把这俩都算数了）
仅仅需要12123这样的数字——有一个唯一数字，另外两个都出现两次才算数。

xiangbaoan

新农夫 发表于 2018-10-3 14:35
您好！再麻烦您一下！
例如：16161不要算数，25555也不要算数（您的代码把这俩都算数了）
仅仅需要1212 ...

Sub test() '前面的是按你的要求做的，那就再做一下请测试
Dim s As New Collection, d As Object, ar(), br
Dim rmb&, lr&, r&, c%, n&, i%, j%, k%
Set d = CreateObject("scripting.dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
br = Range("b2:f" & lr)
ReDim ar(1 To UBound(br), 1 To 1)
For r = 1 To UBound(br)
    d.RemoveAll
    For c = 1 To 5
        s.Add br(r, c)
        d(br(r, c)) = ""
    Next
123
    k = s.Count
    For i = 1 To k - 1
        For j = i + 1 To k
            If s(j) = s(i) Then
                s.Remove (j)
                s.Remove (i)
                GoTo 123
            End If
        Next
    Next
    rmb = n + IIf(s.Count = 1 And d.Count > 2, 6493, -720) '3+2、4+1、5同的都不算
    ar(r, 1) = rmb
    n = rmb
    For i = 1 To s.Count
        s.Remove (1)
    Next
Next
[g2].Resize(UBound(ar)) = ar
Set d = Nothing
End Sub

新农夫

xiangbaoan 发表于 2018-10-3 15:11
Sub test() '前面的是按你的要求做的，那就再做一下请测试
Dim s As New Collection, d As Object, ar() ...

非常感谢！很完美！
真不好意思——又给您添了一次麻烦！
祝您开心愉快！

新农夫

新农夫 发表于 2018-10-3 14:27
excelhome怎么突然变成了惊弓之鸟！动不动就审核。
1、技术论坛莫非还有反动言论？
2、不能带QQ号码，难 ...

知道了。不过说两句废话搞搞节日气氛罢了——您老人家千万别见怪！
祝您以及所有家人节日愉快！

excelvlookup

Sub test()
lr = Cells(Rows.Count, 1).End(xlUp).Row
br = Range("b2:f" & lr)
ReDim ar(1 To UBound(br), 1 To 1)
For i= 1 To UBound(br)
redim rr(9)
r=0
for j=1 to ubound(br,2)
rr(val(br(i,j)))=rr(val(br(i,j)))+1
if rr(val(br(i,j)))=2 then r=r+1
if rr(val(br(i,j)))>= then r=0
next
if r=2 then
   if i=1 then ar(i,1)=6493 else ar(i,j)=ar(i-1,j)+6493
else
   if i=1 then ar(i,1)=-720 else ar(i,j)=ar(i-1,j)-720
end if
next
[g2].Resize(UBound(ar)) = ar
end sub
练个手，没测试过

新农夫

excelvlookup 发表于 2018-10-3 16:33
Sub test()
lr = Cells(Rows.Count, 1).End(xlUp).Row
br = Range("b2:f" & lr)

十分感谢！速度杠杠的！
不妨上个附件——6000多行数据——让各位感兴趣的家人练练手。

祝您节日愉快！
TT8小时.rar (490.67 KB, 下载次数: 17)

2018-10-3 17:00 上传

点击文件名下载附件

xiangbaoan

新农夫 发表于 2018-10-3 14:03
您好！刚才又看了一下，出现了奇怪的现象：一周时间净赚了100多万啊！

呵呵，一周赚100W，这等好事哪里找 ? 还是这个结果好！

新农夫

xiangbaoan 发表于 2018-10-3 18:23
呵呵，一周赚100W，这等好事哪里找 ? 还是这个结果好！

您好！赚钱的事见仁见智很不好说。整天瞎忙的人不赚钱，整天瞎胡搞的主有时候还真赚钱。
咱不说这些破事。

想请您看看16楼的代码，其中少了个>=啥？我猜是>=3或直接>2；
但i运行到“那么，”后边的“ar(i,j)=ar(i-1,j)-720”时，提示“下标越界”；
另外请教一哈：我60多岁了，没学过英语，这辈子还能学会一点VBA不？

祝您开心愉快！

excelvlookup

if rr(val(br(i,j)))>= then r=0
应该是if rr(val(br(i,j)))>2 then r=0
因为没调试，所以有笔误