快速排除已知数,求算法

[VisualBUG]

用循环,快速的在list控件中添加 1 - 6000
在添加过程中需要将含有相同数的排除掉.
例如:
dim i as integer
for i = 1 to 6000
list1.additem i
doevents
next i

'这里假设 i = 234 , 并已经添加进 list1 中去
'在以后的循环中如果遇到 243 , 324 , 342 , 423 , 432 则不予添加.(就是将包含这些数字的统统抛弃掉.)
'用代码如何实现?
'不想生成每个数的时候再用内循环嵌套重新检查list中的已存在数了.效率太低...
'求精炼实力型实例代码... 100分送上!
'谢谢!

[vbman2003]

凑个热闹吧：

Option Explicit

Private Function GetSortValue(ByVal mInput As Integer) As String
    
    Dim i As Long, k As Integer
    Dim min As Integer, max As Integer
    Dim b() As Integer
    Dim tmp As Integer
    Dim s As String
    
    min = Left(mInput, 1)
    max = min
    For i = 1 To Len(CStr(mInput))
        tmp = Mid(mInput, i, 1)
        If tmp > max Then max = tmp
        If tmp < min Then min = tmp
    Next i
    
    ReDim b(min To max)
    For i = 1 To Len(CStr(mInput))
        tmp = Mid(mInput, i, 1)
        b(tmp) = b(tmp) + 1
    Next i
    
    For i = min To max
        If b(i) > 0 Then
            k = 0
            While b(i) - k
                s = s & i
                k = k + 1
            Wend
        End If
    Next i
    GetSortValue = s
    
End Function

Private Sub Command1_Click()
    Dim i As Integer
    Dim b(1 To 6000) As Boolean
    For i = 1 To 6000
        If b(GetSortValue(i)) = False Then
            b(GetSortValue(i)) = True
            List1.AddItem i
        End If
    Next
    Debug.Print List1.ListCount
End Sub

不知道是不是理解对了

[vbman2003]

我晕，突然发现想过头了，改一下吧：

Private Function GetSortValue(ByVal mInput As Integer) As String
    
    Dim i As Long, k As Integer
    Dim b(9) As Integer
    Dim tmp As Integer
    Dim s As String
    
    For i = 1 To Len(CStr(mInput))
        tmp = Mid(mInput, i, 1)
        b(tmp) = b(tmp) + 1
    Next i
    
    For i = 0 To 9
        If b(i) > 0 Then
            k = 0
            While b(i) - k
                s = s & i
                k = k + 1
            Wend
        End If
    Next i
    GetSortValue = s
    
End Function

Private Sub Command1_Click()
    Dim i As Integer
    Dim b(1 To 6000) As Boolean
    For i = 1 To 6000
        If b(GetSortValue(i)) = False Then
            b(GetSortValue(i)) = True
            List1.AddItem i
        End If
    Next
End Sub

好象还是没前面几位快

[KiteGirl]

为了便于你理解，我把我上述的程序以简化的方式提供给你。排序函数采用的是ValueSort2的写法。

Private Sub Command1_Click()
  Dim tList() As Long
  tList() = fncVc()
  Dim tOutStr As String
  For tIndex = 0 To UBound(tList())
    tOutStr = tOutStr & "," & tList(tIndex)
    If Not CBool(tIndex Mod 10) Then tOutStr = tOutStr & vbCrLf
  Next
  Text1.Text = tOutStr
End Sub

Public Function fncVc()
  '返回1-6000所有不冲突的排列。
  Dim tVo() As Long
  Dim tVe As Long

  Dim tVt() As Long
  Dim tVi As Long
  Dim tVs As Long
    
  ReDim tVt(0 To 6000)
  
  Dim tSortValue As Long
  
  '标记表
  
  For tVi = 1 To 6000
    
    tVs = fncVs(tVi)        'tVs=位排序后的tVi。
    tVt(tVs) = tVt(tVs) + 1 '在tVs对应的tVt()表对应位置进行标记。
    
  Next
  
  '从tVt中摘取被标记的元素到tVo。
  
  For tVi = 1 To 6000
    
    If CBool(tVt(tVi)) Then
      
      ReDim Preserve tVo(tVe)
      
      tVo(tVe) = tVi
      tVe = tVe + 1
    
    End If
    
  Next

  fncVc = tVo()
End Function

Public Function fncVs(ByVal pV As Long) As Long
  '值排序函数
  Dim tVo As Long
  
  Dim tBt() As Long
    
  ReDim tBt(0 To 9)
  
  Dim tBi As Long
  Dim tBv As Long
  
  '在Bit取值表标记Bit值
  
  For tBi = 0 To 3
    tBv = (pV \ (10 ^ tBi)) Mod 10  'tBv=tBi位上的值（由于是10进制返回0-9之间的一个数字）
    tBt(tBv) = tBt(tBv) + 1         '在tBv值对应的tBt表项上做标记。
  Next
  
  Dim tBm As Long
  
  '根据Bit值表的标记顺序重组值（也就是实现了排序）
  
  For tBi = 0 To 9
    If CBool(tBt(tBi)) Then
      For tBm = 1 To tBt(tBi)
        tVo = tVo * 10 + tBi
      Next
    End If
  Next
  
  fncVs = tVo
End Function

[KiteGirl]

以上是我提供给你的第一个算法。稍后我再给你个类似的算法，但思路与上述算法略有不同。这个新算法不仅能排除掉冲突的值，而且还能把每一种合法值的所有排列一一归类到一起。

[KiteGirl]

上面的fncVc的算法里，tVt表记录的排序后的元素与其“相仿”的值的数量。通过对应值在tVt表的位置是否大于0来判断该值是否该被排除。

以下是新算法。fncVa返回一个0 to 6000的表，表的每个元素记录的是他们排序后的值。通过判断值在fncVa表里对应值是否等于该值。如果不等则说明该值应该被排除。

下列测试程序返回的结果非常有趣：它返回的是依照每个序列被归类到一起的所有1到6000之间的值。

实际使用当中，还有一种情况可能是：对于3456、4365、6345这三个值，假如第一次出现的是6345，则把6345作为唯一存在的而排斥掉其他的。如果你要这样做的话，应该用fncVa算法，而不是fncVc的算法。当然需要把fncVa改进一下——Va中元素指向的不再是排序后的值，而是排序后的Vs地址中所指向的值。
也就是说：fncVa算法中，4365按照排序规则本来应该指向3456，它并不读取3456中存储的是多少。但我们把这个算法改进一下，让4365在重定向时读一下3456，取3456对应的值。假如3456指向的值被定义为6345，所有指向3456的值都被指向6345。

Private Sub Command1_Click()
Dim tList() As Long
Text1.Text = fncVaEx()
End Sub


Public Function fncVaEx() As String

Dim tSo As String
Dim tVos() As String

ReDim tVos(0 To 6000)

Dim tVa() As Long

tVa() = fncVa()

Dim tVi As Long

For tVi = 0 To 6000

tVos(tVa(tVi)) = tVos(tVa(tVi)) & "," & tVi

Next

For tVi = 0 To 6000

If Not tVos(tVi) = "" Then

tSo = tSo & vbCrLf & tVos(tVi)

End If

Next

fncVaEx = tSo
End Function

Public Function fncVa()
Dim tVo() As Long

ReDim tVo(0 To 6000)

Dim tVt() As Long
Dim tVi As Long
Dim tVs As Long

Dim tSortValue As Long

'标记表

For tVi = 1 To 6000

tVs = fncVs(tVi) 'tVs=位排序后的tVi。
tVo(tVi) = tVs

Next

fncVa = tVo()
End Function

Public Function fncVs(ByVal pV As Long) As Long
'值排序函数
Dim tVo As Long

Dim tBt() As Long

ReDim tBt(0 To 9)

Dim tBi As Long
Dim tBv As Long

'在Bit取值表标记Bit值

For tBi = 0 To 3
tBv = (pV \ (10 ^ tBi)) Mod 10 'tBv=tBi位上的值（由于是10进制返回0-9之间的一个数字）
tBt(tBv) = tBt(tBv) + 1 '在tBv值对应的tBt表项上做标记。
Next

Dim tBm As Long

'根据Bit值表的标记顺序重组值（也就是实现了排序）

For tBi = 0 To 9
If CBool(tBt(tBi)) Then
For tBm = 1 To tBt(tBi)
tVo = tVo * 10 + tBi
Next
End If
Next

fncVs = tVo
End Function

[Tiger_Zhao]

与dlyme的输出结果相同，都是 928 个有效数值。编译成 exe 后速度可以提高 1 个数量级。

Option Explicit
Option Base 1

Const MAX_NUMBER                As Long = 6000

Private aResult(MAX_NUMBER)     As Long                     '直接定义最大容量避免使用 Redim
Private lCount                  As Long                     'aResult 中的有效数的个数

Sub Main()
    计时开始
    Filter
    计时结束

    Check
    SaveFile App.Path & "\NumberList.txt"

    计时开始
    FilterByDlyme
    计时结束

    Check
    SaveFile App.Path & "\DlymeList.txt"
End Sub

'没有根据位数分段进行优化，所以 aResult 中的数值无序也可以检查
Function Check() As Boolean
    Dim bResult                 As Boolean
    Dim i                       As Long
    Dim j                       As Long
    Dim m                       As Long

    bResult = True

    For i = 2 To lCount
        m = aResult(i)
        For j = 1 To i - 1
            If IsHaveSameDigits(m, aResult(j)) Then
                bResult = False
            End If
        Next
    Next

    If bResult = True Then Debug.Print "全部通过。"

    Check = bResult
End Function

Sub Filter()
    Dim lHighPower              As Long                     '最高位权值：1,10,100,1000...
    Dim lHighDigit              As Long                     '用于比较的高位数字
    Dim lLowDigit               As Long                     '用于比较的低位数字
    Dim lDigitPower             As Long                     '用于提取某位数值时的权值：...1000,100,10,1
    Dim bIsOut                  As Boolean
    Dim n                       As Long

    Erase aResult
    lCount = 0

    lHighPower = 1
    While lHighPower <= MAX_NUMBER                          '按位数的多少进行循环
        For n = lHighPower To Min(lHighPower * 10 - 1, MAX_NUMBER)    '对相同位数的数进行判断
            bIsOut = False
            lDigitPower = lHighPower

            lHighDigit = GetDigit(n, lDigitPower)           '取最高位
            If lDigitPower > 0 Then                         'i至少有两位
                lLowDigit = GetDigit(n, lDigitPower)        '取第二位
                While (lLowDigit = 0) And (lDigitPower > 0) '过滤第二位开始的0
                    lLowDigit = GetDigit(n, lDigitPower)
                Wend
                If lLowDigit <> 0 Then                      '类似 6000 没有第二个非零位，不需过滤
                    If lHighDigit > lLowDigit Then          '比较最高位和下个非零位
                        bIsOut = True
                    Else
                        Do While lDigitPower > 0            '逐个比较
                            lHighDigit = lLowDigit
                            lLowDigit = GetDigit(n, lDigitPower)

                            If lHighDigit > lLowDigit Then
                                bIsOut = True
                                Exit Do
                            End If
                        Loop
                    End If
                End If
            End If

            If Not bIsOut Then
                lCount = lCount + 1
                aResult(lCount) = n
            End If
        Next

        lHighPower = lHighPower * 10
    Wend
    Debug.Print "过滤结果：" & lCount & " 个有效数值。"
End Sub

Function GetDigit(ByVal n As Long, ByRef DigitPower As Long) As Long
    GetDigit = (n \ DigitPower) Mod 10
    DigitPower = DigitPower \ 10                            '为取下一位数字做准备
End Function

Function GetDigit2(ByRef n As Long, ByVal DigitPower As Long) As Long
    GetDigit2 = (n \ DigitPower) Mod 10
End Function

Function IsHaveSameDigits(ByVal m As Long, n As Long) As Boolean
    Dim aStateOfM(0 To 9)       As Byte                     '纪录 m 中与每个下标对应的数字出现的次数
    Dim aStateOfN(0 To 9)       As Byte                     '纪录 n 中与每个下标对应的数字出现的次数
    Dim lDigitPower             As Long
    Dim i                       As Long

    lDigitPower = 1
    While (lDigitPower <= m) And (lDigitPower <= n)
        i = GetDigit2(m, lDigitPower)
        aStateOfM(i) = aStateOfM(i) + 1

        i = GetDigit2(n, lDigitPower)
        aStateOfN(i) = aStateOfN(i) + 1

        lDigitPower = lDigitPower * 10
    Wend

    If (lDigitPower <= m) Or (lDigitPower <= n) Then        'm、n 位数不同
        Exit Function                                       'Return False
    Else
        For i = 0 To 9
            If aStateOfM(i) <> aStateOfN(i) Then Exit Function    'Return False
        Next
    End If

    Debug.Print "数值 " & m & " 和 " & n & " 由相同的数字组成。"

    IsHaveSameDigits = True
End Function

Sub SaveFile(ByVal FileName As String)
    Dim hFile                   As Integer
    Dim i                       As Long

    hFile = FreeFile()
    Open FileName For Output Access Write As #hFile
    For i = 1 To lCount
        Write #hFile, aResult(i)
    Next
    Close #hFile
End Sub

'13楼的过滤方式
Sub FilterByDlyme()
    Dim str                     As String
    Dim flag                    As Boolean
    Dim i                       As Long
    Dim first                   As Long
    Dim second                  As Long

    Erase aResult
    lCount = 0

    For i = 1 To MAX_NUMBER
        str = CStr(i)
        flag = True
        first = 1
        second = 2
        While flag And second <= Len(str)
            If Mid(str, second, 1) = "0" Then
                If first > 1 Then
                    If Asc(Mid(str, first, 1)) > Asc(Mid(str, second, 1)) Then
                        flag = False
                    End If
                Else
                    second = second + 1
                End If
            Else
                If Asc(Mid(str, first, 1)) > Asc(Mid(str, second, 1)) Then
                    flag = False
                Else
                    first = second
                    second = second + 1
                End If
            End If
        Wend
        If flag Then
            lCount = lCount + 1
            aResult(lCount) = i
        End If
    Next

    Debug.Print "Dlyme的过滤结果：" & lCount & " 个有效数值。"
End Sub

[KiteGirl]

下面是最新的改进代码，采用我第一种算法。得到928种类别。
这个程序涉及到一个谁先谁后的问题：
对于123、321、231这几个值，如果先遇到321，则排斥123和其他组合。如果先遇到123，则排斥321和其他组合。

仅仅靠排序后的序列不能解决这个问题。

以下程序实现了先后顺序的区别，原理是：遇到一个从未在表中出现的新类别后，将排序后的值指向第一个遇到的属于此类别的值。以后所有值指向到的不是排序后的值，而是排序后的值被替换掉的第一个对应值。

以下用随机序列测试这个新的程序。每当重新点了按键后，有些序列的MasterValue是不同的。

Private Sub Command1_Click()
Dim tI As Long

'产生1-6000随机序列（采用交换法（戏称为“跳蚤算法”的那个））

Dim tR As Long
Dim tV() As Long

ReDim tV(0 To 6000)

For tI = 1 To 6000
tV(tI) = tI
Next

Dim tT As Long

Randomize Timer

For tI = 1 To 6000
tR = Int(Rnd * 6000) + 1
tV(tT) = tV(tI): tV(tI) = tV(tR): tV(tR) = tV(tT)
Next

'对1-6000随机序列进行分类。

Dim tVt() As Long
Dim tVo() As Long

ReDim tVt(0 To 9999)
ReDim tVo(0)

For tI = 1 To 6000

fncVa tV(tI), tVt(), tVo()

Next

Text1.Text = UBound(tVo())

Dim tOs() As String
Dim tS As String

ReDim tOs(0 To 9999)

For tI = 1 To 6000
tOs(tVt(tI)) = tOs(tVt(tI)) & "," & tI
Next

tS = UBound(tVo())

For tI = 1 To 6000
If Not (tOs(tI)) = "" Then
tS = tS & vbCrLf & "MasterValue:" & tI & ";" & (tOs(tI))
End If
Next
Text1.Text = tS 'fncVs(10) 'tS
End Sub

Public Function fncVa(ByVal pV As Long, ByRef pVt() As Long, ByRef pVo() As Long) As Boolean
'添加pV

Dim tVs As Long
Dim tVoe As Long

tVs = fncVs(pV)

tBo = CBool(pVt(tVs))

If Not tBo Then '检测tVs是否有效。

'将tVs指向pV

pVt(tVs) = pV

'添加到序列

tVoe = UBound(pVo()) + 1

ReDim Preserve pVo(tVoe)

pVo(tVoe) = pV

End If

pVt(pV) = pVt(tVs)

fncVa = Not tBo

End Function

Public Function fncVs(ByVal pV As Long) As Long
'值排序函数
Dim tVo As Long

Dim tBt() As Long

ReDim tBt(0 To 9)

Dim tBi As Long
Dim tBv As Long
Dim tBc As Long

tBc = Fix(CDbl(Log(pV)) / CDbl(Log(10)))

For tBi = 0 To tBc
tBv = (pV \ (10 ^ tBi)) Mod 10
tBt(tBv) = tBt(tBv) + 1
Next

Dim tBm As Long

For tBi = 9 To 0 Step -1
If CBool(tBt(tBi)) Then
For tBm = 1 To tBt(tBi)
tVo = tVo * 10 + tBi
Next
End If
Next

fncVs = tVo
End Function

[VisualBUG]

感谢各位的支持和热心的解答.问题已经解决.学习了...
这里网速很慢,下班后结贴...

谢谢!

[VisualBUG]

vbMan 2003 的方法不错,相对简单更容易理解.
KiteGirl 的确有才,学到了新方法!
Tiger_Zhao 全程关注,提供的方法我得细嚼慢咽..
dlyme 的方法也好,但是相对来说太复杂了,谢谢!

有7年没怎么接触过vb了,嗯,是的,最少7年了.... 这是我的小号,主ID是: lstar
hand in hand , play up ~~
谢谢大家的帮助!

[vbman2003]

感觉 dlyme和Tiger_Zhao 的结果好象更接近楼主的要求吧，而且效率不错
我那个是借鉴小仙妹的思路用了排序，但结果感觉有问题......
如果用排序法要得到dlyme那样的结果，那么应该用逆序。也就是比如所有 123、132、231、213、321......等等，全部看成321

[vbman2003]

下面这个结果和dlyme和Tiger_Zhao一样了928个，不过算法还要再推敲：

Private Function GetSortValue(ByVal mInput As Integer) As Integer
    
    Dim i As Integer, j As Integer, k As Integer
    Dim p(9) As Integer
    Dim tmp As Integer
    Dim s As String
    
    j = Len(CStr(mInput))
    For i = 1 To j
        tmp = Mid(mInput, i, 1)
        p(tmp) = p(tmp) + 1
    Next i
    
    For i = 9 To 0 Step -1
        If p(i) > 0 Then
            k = 0
            While p(i) - k
                s = s & i
                k = k + 1
            Wend
        End If
    Next i
    GetSortValue = CInt(s)
    
End Function

Private Sub Command1_Click()
    List1.Clear
    Dim i As Integer
    Dim b(1 To 9995) As Boolean
    Dim tmp As Integer
    
    For i = 1 To 6000
        tmp = GetSortValue(i)
        If Not b(tmp) Then
            b(tmp) = Not b(tmp)
            List1.AddItem i
        End If
    Next
    Debug.Print List1.ListCount
End Sub

[vbman2003]

KiteGirl 的这个排序算法学习了

[KiteGirl]

我研究了一下，得到928个结果是把12、21与1002、1020以及102、201统统区分出来导致的。
我的算法里把12、21看成0012和0021。把102、201当做0102和0201。区别应该就在这里。

下面程序可以得到全部序列归类，可以根据这个序列分析。

Private Sub Command1_Click()
Text1.Text = fncVaEx()
End Sub

Public Function fncVaEx() As String

Dim tSo As String
Dim tVos() As String

ReDim tVos(0 To 6000)

Dim tVa() As Long

tVa() = fncVa()

Dim tVi As Long

For tVi = 0 To 6000

tVos(tVa(tVi)) = tVos(tVa(tVi)) & "," & tVi

Next

For tVi = 0 To 6000

If Not tVos(tVi) = "" Then

tSo = tSo & vbCrLf & tVos(tVi)

End If

Next

fncVaEx = tSo
End Function

Public Function fncVa()
Dim tVo() As Long

ReDim tVo(0 To 6000)

Dim tVt() As Long
Dim tVi As Long
Dim tVs As Long

Dim tSortValue As Long

'标记表

For tVi = 1 To 6000

tVs = fncVs(tVi) 'tVs=位排序后的tVi。
tVo(tVi) = tVs

Next

fncVa = tVo()
End Function

Public Function fncVs(ByVal pV As Long) As Long
'值排序函数
Dim tVo As Long

Dim tBt() As Long

ReDim tBt(0 To 9)

Dim tBi As Long
Dim tBv As Long

'在Bit取值表标记Bit值

For tBi = 0 To 3
tBv = (pV \ (10 ^ tBi)) Mod 10 'tBv=tBi位上的值（由于是10进制返回0-9之间的一个数字）
tBt(tBv) = tBt(tBv) + 1 '在tBv值对应的tBt表项上做标记。
Next

Dim tBm As Long

'根据Bit值表的标记顺序重组值（也就是实现了排序）

For tBi = 0 To 9
If CBool(tBt(tBi)) Then
For tBm = 1 To tBt(tBi)
tVo = tVo * 10 + tBi
Next
End If
Next

fncVs = tVo
End Function

[Tiger_Zhao]

vbman2003用标志的方法应该是首选，我最初为了与dlyme的输出进行比较和校验而用了存值法，其实标志法最简洁，当然求hash值应该用KiteGirl的操着方式性能更好一点。
KiteGirl在标志法的基础上达实现了分组输出的功能，非常不错。

[KiteGirl]

哈哈！我又想出一个新算法，稍后给你这个新算法。如果你看过该算法，你会觉得我上面那个算法实在太笨了。

[KiteGirl]

这是新算法，感觉它未必更好，但比较有趣。新算法原理如下：

对于数字2999，如果统计它的位直方图则是。

0 1 2 3 4 5 6 7 8 9
0 0 1 0 0 0 0 0 0 3

在6000以内的数字范围内，直方图的取值范围在0到4之间。可以用10位五进制来表达6000以内所有的直方图。这样就得到一个VBH值：

VBH=B9*5^9+B8*5^8+……+B0*5^0

2999的VBH值是5859400

如果两个值的VBH相同，则两个值包含同等种类、且每个种类数量相同的数字。

10位五进制的值取值范围在0到9765624之间，如果用标志法需占用40MB的内存，这是目前的计算机可以承受的。

以下是VBH算法，它可以求出928个结果，与上面dlyme和Tiger_Zhao的一样。

Private Sub Command1_Click()
  Dim tList() As Long
  'tList() = ValueListGet()
  Text1.Text = fncVaEx() 'UBound(tList()) ' fncVaEx() 'tOutStr
End Sub

Private Sub Command2_Click()
  Text1.Text = Fix(Log(9999) / Log(10))
End Sub

Public Function fncVaEx() As String
  
  Dim tSo As String
  Dim tVos() As String
  
  ReDim tVos(0 To 9765625)
  
  Dim tVa() As Long
  
  tVa() = fncVa()
  
  Dim tVi As Long
  
  For tVi = 0 To 6000
  
    tVos(tVa(tVi)) = tVos(tVa(tVi)) & "," & tVi
  
  Next
  
  For tVi = 0 To 9765625
  
    If Not tVos(tVi) = "" Then
      
      tSo = tSo & vbCrLf & tVos(tVi)
      
    End If
  
  Next
    
  fncVaEx = tSo
End Function

Public Function fncVa()
  Dim tVo() As Long
  
  ReDim tVo(0 To 6000)

  Dim tVt() As Long
  Dim tVi As Long
    
  '标记表
  
  For tVi = 1 To 6000
    
    tVo(tVi) = fncVBH(tVi)
    
  Next
  
  fncVa = tVo()
End Function

Private Function fncVBH(ByVal pV As Long) As Long   'Value Bit Histogram
  Dim tVo As Long
  Dim tBt(0 To 9) As Long
  
  Dim tBi As Long
  Dim tBv As Long
  Dim tBc As Long
  
  '求Bit直方图VBH。
  
  tBc = Fix(Log(pV) / Log(10))
  
  For tBi = 0 To tBc
    tBv = (pV \ (10 ^ tBi)) Mod 10  'tBv=tBi位上的值（由于是10进制返回0-9之间的一个数字）
    tBt(tBv) = tBt(tBv) + 1         '在tBv值对应的tBt表项上做标记。
  Next
  
  Dim tBm As Long
  
  '以5进制压缩直方图
  
  For tBi = 0 To 9
    tVo = tVo + tBt(tBi) * 5 ^ tBi
  Next
  
  fncVBH = tVo
End Function

[KiteGirl]

改进了一下VBH算法的导出程序，速度明显改善：

Public Function fncVaEx() As String
  
  Dim tSo As String
  Dim tVos() As String
  
  ReDim tVos(0 To 9765625)
  
  Dim tVa() As Long
  
  tVa() = fncVa()
  
  Dim tVi As Long
  
  For tVi = 0 To 6000
  
    tVos(tVa(tVi)) = tVos(tVa(tVi)) & "," & tVi
  
  Next
  
  For tVi = 0 To 6000
  
    If Not tVos(tVa(tVi)) = "" Then
      tSo = tSo & tVos(tVa(tVi)) & vbCrLf
    End If
      
    tVos(tVa(tVi)) = ""
  
  Next
      
  fncVaEx = tSo
End Function

[vbman2003]

感叹！小仙妹真是奇思妙想.....呵呵，学习！

[Tiger_Zhao]

这只是hash函数的差异，而且在有效hash值个数（928）不变的情况下增大映射的目标区间并不是一种可取的方式。
设法减小目标区间才应该是努力的方向。

[KiteGirl]

VB老鸟言之有理，VBH的算法确实太占空间了。还是改进一下标志法更好。