导航
  • 主页
会员中心
收藏
消息
创作中心

快速排除已知数,求算法

VisualBUG 2007-12-19 12:37:25
用循环,快速的在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分送上!
'谢谢!
...全文
205 点赞 收藏 41
写回复
41 条回复
切换为时间正序
请发表友善的回复…
发表回复
KiteGirl 2007-12-21
VB老鸟言之有理，VBH的算法确实太占空间了。还是改进一下标志法更好。
 回复 赞
Tiger_Zhao 2007-12-21
这只是hash函数的差异，而且在有效hash值个数（928）不变的情况下增大映射的目标区间并不是一种可取的方式。
设法减小目标区间才应该是努力的方向。
 回复 赞
vbman2003 2007-12-21
感叹！小仙妹真是奇思妙想.....呵呵，学习！
 回复 赞
KiteGirl 2007-12-21
改进了一下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
回复 赞
KiteGirl 2007-12-21
这是新算法，感觉它未必更好，但比较有趣。新算法原理如下：

对于数字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 2007-12-21
哈哈！我又想出一个新算法，稍后给你这个新算法。如果你看过该算法，你会觉得我上面那个算法实在太笨了。
 回复 赞
Tiger_Zhao 2007-12-21
vbman2003用标志的方法应该是首选，我最初为了与dlyme的输出进行比较和校验而用了存值法，其实标志法最简洁，当然求hash值应该用KiteGirl的操着方式性能更好一点。
KiteGirl在标志法的基础上达实现了分组输出的功能，非常不错。
 回复 赞
KiteGirl 2007-12-21
我研究了一下，得到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
 回复 赞
vbman2003 2007-12-21
KiteGirl 的这个排序算法学习了
 回复 赞
vbman2003 2007-12-21
下面这个结果和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 2007-12-21
感觉 dlyme和Tiger_Zhao 的结果好象更接近楼主的要求吧，而且效率不错
我那个是借鉴小仙妹的思路用了排序，但结果感觉有问题......
如果用排序法要得到dlyme那样的结果，那么应该用逆序。也就是比如所有 123、132、231、213、321......等等，全部看成321
 回复 赞
VisualBUG 2007-12-21
vbMan 2003 的方法不错,相对简单更容易理解.
KiteGirl 的确有才,学到了新方法!
Tiger_Zhao 全程关注,提供的方法我得细嚼慢咽..
dlyme 的方法也好,但是相对来说太复杂了,谢谢!

有7年没怎么接触过vb了,嗯,是的,最少7年了.... 这是我的小号,主ID是: lstar
hand in hand , play up ~~
谢谢大家的帮助!
回复 赞
VisualBUG 2007-12-21
感谢各位的支持和热心的解答.问题已经解决.学习了...
这里网速很慢,下班后结贴...

谢谢!
 回复 赞
KiteGirl 2007-12-21
下面是最新的改进代码，采用我第一种算法。得到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

 回复 赞
Tiger_Zhao 2007-12-20
与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 2007-12-20
上面的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
 回复 赞
KiteGirl 2007-12-20
以上是我提供给你的第一个算法。稍后我再给你个类似的算法，但思路与上述算法略有不同。这个新算法不仅能排除掉冲突的值，而且还能把每一种合法值的所有排列一一归类到一起。
 回复 赞
KiteGirl 2007-12-20
为了便于你理解，我把我上述的程序以简化的方式提供给你。排序函数采用的是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
回复 赞
vbman2003 2007-12-20
我晕，突然发现想过头了，改一下吧：


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

好象还是没前面几位快
 回复 赞
vbman2003 2007-12-20
凑个热闹吧：



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


不知道是不是理解对了
 回复 赞
发动态
发帖子
VB基础类
创建于2007-09-28

7451

社区成员

19.7w+

社区内容

VB 基础类
申请成为版主
社区公告
暂无公告