7,785
社区成员




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