[第53期]EXCEL26进制来回转换 ---------已结

ldy · 发表于 2009-9-17 10:13

前几天有会员把清风版主4年前老贴翻了上来。
将数字转化为字符26进制(以A-Z表示)的自定义函数http://club.excelhome.net/thread-89959-1-2.html
这对VBA的用户来说是很有吸引力的，把它改编扩展作为本期竞赛题。
清风版主的代码如下：请复制以便验证

Function NumToChar_26(Num As Double) as string
Dim iMod As Integer, dInt As Double, sChar As String
'Application.Volatile
iMod = Num Mod 26
dInt = Num \ 26
If iMod > 0 Then
sChar = Split(Columns(iMod).Address(0, 0), ":")(0)
ElseIf dInt > 0 Then
dInt = dInt - 1
sChar = "Z"
End If
Do While dInt > 0
iMod = dInt Mod 26
dInt = dInt \ 26
If iMod > 0 Then
sChar = Split(Columns(iMod).Address(0, 0), ":")(0) & sChar
ElseIf dInt > 0 Then
dInt = dInt - 1
sChar = "Z" & sChar
End If
Loop
NumToChar_26 = sChar
End Function

复制代码

题目1：1分
请编写反向函数例如把 IV 转化成 256， XFD转换为16384。
答题统一格式如下

Function N2Char26R(ByVal L As String) As Double
'你的代码要求EXCEL2003下可运行
'要求不仅限于 2003的IV（256) 和 2007 的XFD（16384列）
'具体要求请运行验证1
End Function
Sub 验证1()
Dim x As Double, y As Double, z As Double, s As String, v As Byte
On Error Resume Next
x = 2147483647 '(不考虑小数负数和 0)
s = NumToChar_26(x)
y = N2Char26R(s)
z = N2Char26R("fywmusmjify")
If y = x Then v = 1
If z = 987654321012345# And v = 1 Then v = 2
If v = 2 Then
MsgBox "正确，可得1分"
ElseIf v = 1 Then
MsgBox "代码需要调试。可得0.5分，视最后得分是否< 1 取舍。"
Else
MsgBox "错误，继续努力"
End If
End Sub

复制代码

题目2: 1-2分
NumToChar_26 函数毕竟是清风版主4年前的代码，我们还有优化的空间。
NumToChar_26 转换最大值就是验证1 里的 2147483647 ，
编写函数以实现可以转换大于2147483647 的数，并且尝试提速
函数统一格式如下：

Function N2Char26(ByVal L as Double) As String
'你的代码要求EXCEL2003下可运行
'具体要求请运行验证2
End Function
Sub 验证2()
Dim x As Double, y As Double, s1 As String, s2 As String
x = 2147483647 '(不考虑小数负数和 0)
y = x * 10
t = Timer
Const runtm = 10000
On Error GoTo 111
For i = 1 To runtm
s1 = NumToChar_26(x)
Next
tm1 = Timer - t ' 大约 1 秒钟
t = Timer
For i = 1 To runtm
s2 = N2Char26(y)
Next
tm2 = Timer - t
If s2 = "BQMKIGNV" Then
MsgBox "结果正确，可得1分"
Else
MsgBox "结果错误, 不得分"
Exit Sub
End If
If tm2 * 2 < tm1 Then
MsgBox tm1 & " " & tm2 & " 速度达标，可再得1分"
Else
MsgBox tm1 & " " & tm2 & " 太慢了，继续努力"
End If
Exit Sub
111
MsgBox "运行错误, 不得分"
End Sub

复制代码

全部验证通过可得3分。
答题者请跟帖占位，跟帖中不要出现与题目相关的内容，否则不予评分。
截止日期 2009-10-20 以发邮件时间为准。
答案请按如下格式发送到邮箱 26258103@163.com （不需要附件，纯文字即可）

邮件主题： VBA53期答案
邮件内容：

'论坛ID：xxxxxxx
Function N2Char26R(ByVal L As String) As Double
'你的代码要求EXCEL2003下可运行
End Function
Function N2Char26(ByVal L as Double) As String
'你的代码要求EXCEL2003下可运行
End Function

复制代码

临近国庆中秋长假8天，所以提前出题，分也比较好得。
此题说难不难，说易不易。
说不难是因为用不到高深生僻的语句，仅仅是数字和字符串操作，初学者也有机会得分。
说不易是因为要得全分就要对VBA 操作符的限制有一定的了解，以及代码优化的经验。

答题愉快，节日快乐。

参考答案：

'ID :LDY
Function N2Char26(ByVal L As Double) As String
Do While L > 0
N2Char26 = Chr(L - Int(L / (26.0000000000001)) * 26 + 64) & N2Char26
L = Int(L / (26.0000000000001))
Loop
End Function
Function N2Char26(ByVal L As Double) As String '第二版本，稍微慢一点，便于和玩转N进制比较
Const Jzs As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Do
N2Char26 = Mid(Jzs, L - Int(L / 26.0000000000001) * 26, 1) & N2Char26
L = Int(L / (26.0000000000001))
Loop While L > 0
End Function
Function N2Char26R(ByVal L As String) As Double
L = UCase(L)
For i% = 1 To Len(L)
N2Char26R = N2Char26R + (Asc(Mid(L, i)) - 64) * 26 ^ (Len(L) - i)
Next
End Function

复制代码

结贴 http://club.excelhome.net/viewthread.php?tid=484032&page=4#pid3244334

[ 本帖最后由 ldy 于 2009-10-22 15:11 编辑 ]

泓() · 发表于 2009-9-17 20:02

请刘版查收.审核

您的邮件已发送
此邮件发送成功，并已保存到“已发送”文件夹。

刘版能否结出参赛者的运行速度

'论坛ID：泓() OK +3
Function N2Char26(ByVal L As Double) As String
Dim a() As Byte, i As Long, v As Double, s As String
For i = 1 To 10000
ReDim Preserve a(1 To i)
v = Int(L / 26 ^ (i - 1))
If v > 26 Then
a(i) = v - Int(v / 26) * 26
If a(i) = 0 Then a(i) = 26
L = L - a(i) * 26 ^ (i - 1)
Else
a(i) = v
Exit For
End If
Next
For i = 1 To UBound(a)
s = Chr(a(i) + 64) & s
Next
N2Char26 = s
End Function
Function N2Char26R(ByVal L As String) As Double
Dim n As Long, i As Long, v As Double
n = Len(L)
If n = 0 Then Exit Function
L = UCase(L)
ReDim a(1 To n)
For i = 1 To n
a(i) = Asc(Mid(L, i, 1)) - 64
v = a(i) * 26 ^ (n - i) + v
Next
N2Char26R = v
End Function

复制代码

[ 本帖最后由 ldy 于 2009-10-21 16:42 编辑 ]

zhoukick · 发表于 2009-9-18 08:13

占位

'论坛ID：Zhoukick 26的整倍数未通过验证错误(26=AZ ?) Z = 0 ? ，不得分谢谢参与
Function N2Char26R(ByVal L As String) As Double
'你的代码要求EXCEL2003下可运行
Dim N As Double, J As Double, P As Integer
J = 1
L = UCase(L)
For i = Len(L) To 1 Step -1
P = Asc(Mid(L, i, 1)) - 64
If P = 26 Then P = 0
N = N + P * J
J = J * 26
Next
N2Char26R = N
End Function
Function N2Char26(ByVal L As Double) As String
'你的代码要求EXCEL2003下可运行
Dim X As Double, P As Integer, S As String
While L > 0
X = Int(L / 26)
P = L - X * 26
L = X
If P = 0 Then P = 26
P = P + 64
S = Chr(P) & S
Wend
N2Char26 = S
End Function

复制代码

[ 本帖最后由 ldy 于 2009-10-21 16:44 编辑 ]

formatD · 发表于 2009-9-18 09:07

邮件已发送，请斑竹查收

'论坛ID：formatd 26的整倍数未通过验证错误(52=BZ ?) ，1 分
Function N2Char26R(ByVal L As String) As Double
'你的代码要求EXCEL2003下可运行
'要求不仅限于 2003的IV（256) 和 2007 的XFD（16384列）
'具体要求请运行验证1
Dim v As Double
L = UCase(L)
For i = 1 To Len(L)
v = v * 26 + Asc(Mid(L, i, 1)) - 64
Next i
N2Char26R = v
End Function
Function N2Char26(ByVal L As Double) As String
'你的代码要求EXCEL2003下可运行
' 简单递归代替循环方式-ldy
Dim iMod As Integer, s As String, is26 As Integer, iDiv as Double
If L <= 26 Then
N2Char26 = Chr(L + 64)
Else
iDiv = CLng(L / 26 - 0.5)
iMod = L - iDiv * 26
is26 = Int(iMod = 26)
s = IIf(iMod = 0, "Z", Chr(64 + iMod))
N2Char26 = N2Char26(iDiv - is26) & s
End If
End Function

复制代码

[ 本帖最后由 ldy 于 2009-10-21 16:45 编辑 ]

alzeng · 发表于 2009-9-18 15:08

邮件已发送,请版主查阅.

'【alzeng】 ok 26的整倍数未通过验证 (26=A@ ?) ，1 分
Function N2Char26R(ByVal L$) As Double
Dim i As Byte, str$
str = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
L = UCase(L)
N2Char26R = InStr(str, Right(L, 1))
If Len(L) > 1 Then
For i = 1 To Len(L) - 1
N2Char26R = N2Char26R + InStr(str, Mid(L, i, 1)) * 26 ^ (Len(L) - i)
Next
End If
End Function
Function N2Char26(ByVal L#) As String '26的整倍数补答通过验证
Dim i, k, Arr
i = 0
L = L / 10
Do Until 26 ^ i / 10 > L
i = i + 1
Loop
ReDim Arr(i)
Arr(1) = (L + 0.01 - Int((L + 0.01) / 2.6) * 2.6) * 10
For k = 2 To i
Arr(k) = Int(L * 10 / 26 ^ (k - 1)) Mod 26
Next
For k = 1 To i
If k < i And Arr(k) < 1 Then Arr(k) = Arr(k) + 26: If k < i Then Arr(k + 1) = Arr(k + 1) - 1
N2Char26 = IIf(Arr(k) < 1, "", Chr(64 + Arr(k))) & N2Char26
Next
End Function
Function N2Char26(ByVal L#) As String '26的整倍数未通过验证 (26=A@ ?)
Dim str$, i As Byte, k As Byte
str = "ZABCDEFGHIJKLMNOPQRSTUVWXYZ"
i = 0
L = L / 10
Do Until 26 ^ i / 10 >= L
i = i + 1
Loop
N2Char26 = Mid(str, ((L - Int(L / 2.6) * 2.6) * 10 Mod 26) + 1, 1)
If i > 1 Then
L = Int(L / 2.6) * 2.6
For k = 2 To i
N2Char26 = Mid(str, Int(L * 10 / 26 ^ (k - 1)) Mod 26 + 1, 1) & N2Char26
L = L - 26 ^ (k - 1) / 10
Next
End If
End Function

复制代码

[ 本帖最后由 ldy 于 2009-10-21 16:46 编辑 ]

zm0115 · 发表于 2009-9-18 15:57

邮件已发送，请版主审查，第一次参加竞赛，心情老激动了。

哦，刚才贴了附件，谢谢楼上哥们提醒，好像不能发附件的哈。。不好意思，不好意思

'论坛ID：zm0115 26的整倍数未通过验证 (26=A@ ?) ，1 分
Function N2Char26R(ByVal L As String) As Double
Dim num As Double, k As Byte, n As Byte
For n = 1 To Len(L)
k = Asc(UCase(Mid(L, n, 1))) - 64
num = num + k * 26 ^ (Len(L) - n)
Next
N2Char26R = num
End Function
Function N2Char26(ByVal L As Double) As String
Dim iMod As Integer, dInt As Double, sChar As String, k As Byte
iMod = Int(WorksheetFunction.Log(L, 26))
For x = iMod To 0 Step -1
k = Int(L / 26 ^ x)
L = L - k * 26 ^ x
sChar = sChar & Chr(k + 64)
Next
N2Char26 = sChar
End Function

复制代码

[ 本帖最后由 ldy 于 2009-10-21 16:47 编辑 ]

ldy · 发表于 2009-9-18 16:59

以上5位的邮件都收到了。

shuts32 · 发表于 2009-9-18 19:07

占位~邮件已发请版主查收!!

收到。 ldy

'论坛ID：shuts32 OK + 3 用chr可以简化select
Function N2Char26R(ByVal L As String) As Double
'你的代码要求EXCEL2003下可运行
'要求不仅限于 2003的IV（256) 和 2007 的XFD（16384列）
'具体要求请运行验证1
Dim LenL As Long, i As Long, n2char As Double
Dim j As String
LenL = Len(L)
i = 1
Do While i <= Len(L)
j = Mid(L, i, 1) & ":" & Mid(L, i, 1)
n2char = n2char + Columns(j).Column * 26 ^ (LenL - 1)
LenL = LenL - 1
i = i + 1
Loop
N2Char26R = n2char
End Function
Function N2Char26(ByVal L As Double) As String
'你的代码要求EXCEL2003下可运行
'具体要求请运行验证2
Dim iMod As Integer, dInt As Double, sChar As String
'Application.Volatile
iMod = L - Int(L / 26) * 26
dInt = Int(L / 26)
Do
Select Case iMod
Case 1
sChar = "A" & sChar
Case 2
sChar = "B" & sChar
Case 3
sChar = "C" & sChar
Case 4
sChar = "D" & sChar
Case 5
sChar = "E" & sChar
Case 6
sChar = "F" & sChar
Case 7
sChar = "G" & sChar
Case 8
sChar = "H" & sChar
Case 9
sChar = "I" & sChar
Case 10
sChar = "J" & sChar
Case 11
sChar = "K" & sChar
Case 12
sChar = "L" & sChar
Case 13
sChar = "M" & sChar
Case 14
sChar = "N" & sChar
Case 15
sChar = "O" & sChar
Case 16
sChar = "P" & sChar
Case 17
sChar = "Q" & sChar
Case 18
sChar = "R" & sChar
Case 19
sChar = "S" & sChar
Case 20
sChar = "T" & sChar
Case 21
sChar = "U" & sChar
Case 22
sChar = "V" & sChar
Case 23
sChar = "W" & sChar
Case 24
sChar = "X" & sChar
Case 25
sChar = "Y" & sChar
Case 0
sChar = "Z" & sChar
dInt = dInt - 1
End Select
If dInt = 0 Then Exit Do
iMod = dInt - Int(dInt / 26) * 26
dInt = Int(dInt / 26)
Loop
N2Char26 = sChar
End Function

复制代码

[ 本帖最后由 ldy 于 2009-10-21 16:48 编辑 ]

zldccmx · 发表于 2009-9-19 11:27

邮件发送成功！·邮件已通过卡巴斯基杀毒引擎扫描
·邮件已经自动保存到“已发送”文件夹 [取消自动保存]

'ID:zldccmx 26的整倍数未通过验证 +1
'撰写:老朽
'网址:http://Club.ExcelHome.net
'日期:2009-9-19 上午 11:18:59
Function N2Char26R(ByVal L As String ) As Double
'你的代码要求EXCEL2003下可运行
'要求不仅限于 2003的IV（256) 和 2007 的XFD（16384列）
'具体要求请运行验证1
For i = 1 To Len(L)
N2Char26R = N2Char26R + Cells(1, Mid(L, i, 1)).Column * (26 ^ (Len(L) - i))
Next
End Function
'撰写:老朽
'网址:http://Club.ExcelHome.net
'日期:2009-9-19 上午 11:18:59
Function N2Char26(ByVal L As Double ) As String
'你的代码要求EXCEL2003下可运行
'具体要求请运行验证2
Arr = Array("Z", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
Do While L > 26
J = Int(L / 26): K = L - J * 26: L = J
N2Char26 = Arr(K) & N2Char26
Loop
N2Char26 = Arr(L) & N2Char26
End Function

复制代码

收到 --ldy

[ 本帖最后由 ldy 于 2009-10-21 16:50 编辑 ]

winland · 发表于 2009-9-19 12:29

很久没有做竞赛题了，看起来这个简单一些，来试试。
邮件已发送，请刘版查收，多谢。

收到 --ldy

'论坛ID: winland 26的整倍数未通过验证 +1
Function N2Char26R(ByVal L As String) As Double
'你的代码要求EXCEL2003下可运行
Dim i As Integer, iLen As Integer
iLen = Len(L)
For i = 1 To iLen
N2Char26R = N2Char26R + (Asc(UCase(Mid(L, i, 1))) - 64) * (26 ^ (iLen - i))
Next i
End Function
Function N2Char26(ByVal L As Double) As String
'你的代码要求EXCEL2003下可运行
Dim iLen As Integer, iTemp As Integer, dTemp As Double
iLen = Int(Log(L) / Log(26))
dTemp = L
For i = iLen To 1 Step -1
iTemp = Int(dTemp / (26 ^ i))
dTemp = dTemp - iTemp * 26 ^ i
N2Char26 = N2Char26 & Chr(iTemp + 64)
Next i
N2Char26 = N2Char26 & Chr(dTemp + 64)
End Function

复制代码

[ 本帖最后由 ldy 于 2009-10-21 16:51 编辑 ]

		自动登录	找回密码
密码			免费注册

[Excel 程序开发] [第53期]EXCEL26进制来回转换 ---------已结

评分

本帖子中包含更多资源

评分

评分

评分

评分

评分

本帖子中包含更多资源

评分

评分

最新热点 /1