• 主页

# 快速排除已知数,求算法

VisualBUG 2007-12-19 12:37:25

dim i as integer
for i = 1 to 6000
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

vbman2003 2007-12-21

KiteGirl 2007-12-21

``````

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

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

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

2999的VBH值是5859400

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

``````

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

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

``````
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)
End If
Next
Debug.Print List1.ListCount
End Sub

``````

vbman2003 2007-12-21

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

hand in hand , play up ~~

VisualBUG 2007-12-21

KiteGirl 2007-12-21

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

``````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

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

``````

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
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
End If
Next
Debug.Print List1.ListCount
End Sub

``````

VB基础类

7451

VB 基础类