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

trustwxq · 发表于 2009-9-19 17:36

先做了第一题，占位，呵呵~~
现在第二题也做完了，运行时间是原来的约1/20.
图片贴不上来了，时间分别是 .875 和 .046875,呵呵~~

刚刚参加了第52期竞赛题目的回答，又来参加第53期，经常有题做，经常有的玩，有的学真好，谢谢楼主给我们机会！

[ 本帖最后由 trustwxq 于 2009-9-20 11:57 编辑 ]

收到 ——ldy

'论坛ID: trustwxq Ok +3
'第一题:
Function N2Char26R(ByVal L As String) As Double
Dim result As Double, m As Integer, n As Integer, str1 As String
str1 = UCase(L)
result = 0
For m = 1 To Len(str1)
n = Asc(Mid(str1, m, 1)) - Asc("A") + 1
result = result + n * (26 ^ (Len(str1) - m))
Next
N2Char26R = result
End Function
'第二题:
Function N2Char26(ByVal Le As Double) As String
Dim yushu As Double, zhgshu As Double, transc As String
zhgshu = Le
transc = ""
Do While zhgshu > 26
yushu = Int(zhgshu / 26)
yushu = zhgshu - yushu * 26
zhgshu = Int(zhgshu / 26)
If yushu = 0 Then
yushu = 26
zhgshu = zhgshu - 1
End If
transc = Chr(64 + yushu) & transc
Loop
If zhgshu = 0 Then
N2Char26 = transc
Else
N2Char26 = Chr(64 + zhgshu) & transc
End If
End Function

复制代码

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

unsamesky · 发表于 2009-9-19 21:18

晕死，抱歉，版主，第一封邮件忘发论坛ID号了。所以重又发了一封，对您造成的不便，请见谅！

收到 ——ldy

'论坛ID了： unsamesky 26的整倍数转换错误 +1分
'字符转数字
Function N2Char26R(ByVal L As String) As Double
Dim numA As Byte, numB As Double
Dim i As Byte
For i = 1 To Len(L)
numA = Asc(LCase(Mid(L, i, 1))) - 96
numB = numB + numA * (26 ^ (Len(L) - i))
Next
N2Char26R = numB
End Function
'数字转字符
Function N2Char26(ByVal L As Double) As String
Dim strA As String, numA As Double, numB As Double, numC As Double
numB = L
Do While numB > 26
numA = numB - Int(numB / 26) * 26 '存储余数
numC = Int(numB / 26) '存储被除后结果的整数部分
strA = Chr(numA + 64) & strA '将余数转换成字母
numB = numC
Loop
N2Char26 = Chr(numB + 64) & strA
End Function

复制代码

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

smhf_6 · 发表于 2009-9-20 07:31

邮件已于2009.9.20 7：19发送，请版主查收

收到 ——ldy

'论坛ID：smhf_6 结果正确但速度未达标 +2
Function N2Char26R(ByVal L As String) As Double
'要求不仅限于 2003的IV（256) 和 2007 的XFD（16384列）
'具体要求请运行验证1
Dim ch%, i%, p%
ch = Len(L)
L = UCase(L)
For i = 1 To ch
p = Application.Lookup(Mid(L, i, 1), [{"A",1;"B",2;"C",3;"D",4;"E",5;"F",6;"G",7;"H",8;"I",9;"J",10;"K",11;"L",12;"M",13;"N",14;"O",15;"P",16;"Q",17;"R",18;"S",19;"T",20;"U",21;"V",22;"W",23;"X",24;"Y",25;"Z",26}])
N2Char26R = N2Char26R + p * 26 ^ (ch - i)
Next
End Function
Function N2Char26(ByVal L As Double) As String
'你的代码要求EXCEL2003下可运行
'具体要求请运行验证2
Dim i As Integer
Dim b(26) As Byte
Dim s As String
Do Until L = 0
' b(i) = L Mod 26 ' 当L>2147483647时出错，“溢出”
b(i) = L - 26 * Int(L / 26) ' 除26取余
' L = L \ 26 ' 当L>2147483647时出错，“溢出”
L = Int(L / 26)
If b(i) = 0 And L > 0 Then
b(i) = 26
L = L - 1
End If
i = i + 1
Loop
Do While i > 0
i = i - 1
p = Choose(b(i), "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")
s = s & p ' 反序排列
Loop
N2Char26 = s
End Function

复制代码

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

jymao · 发表于 2009-9-20 11:34

我也来班门弄斧...
占位,邮件已发送,等分...
为什么我的图片无法插入了?

收到 ——ldy

'Uname：jymao; OK +3
Function N2Char26(ByVal L As Double) As String
Dim s$, c%, d As Double
If (L > 0) Then
Do
d = Application.WorksheetFunction.RoundDown(L / 26, 0)
c = L - d * 26
L = d
If c = 0 Then
c = 26
L = L - 1
End If
s = Chr(c + 64) & s
If (L < 27) Then
If L > 0 Then
s = Chr(L + 64) + s
End If
Exit Do
End If
Loop
End If
N2Char26 = s
End Function
Function N2Char26R(ByVal L As String) As Double
Dim i%, s$, c%, j
For i = 1 To Len(L)
s = UCase(Mid(L, i, 1))
c = Asc(s)
If (c > 64 And c < 91) Then
j = ((c - 64) * 26 ^ (Len(L) - i)) + j
End If
Next
N2Char26R = CDec(j)
End Function

复制代码

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

taller · 发表于 2009-9-20 13:19

参与一下，感谢刘版国庆送分

邮件已经发送，请查收

收到 ——ldy

'论坛ID：taller 26的整倍数验证未通过（26=AZ) +1
Function N2Char26R(ByVal L As String) As Double
Dim n As Double, i As Integer, StrLen As Integer
L = VBA.UCase$(L): StrLen = VBA.Len(L)
For i = 1 To StrLen
n = n + (VBA.Asc(VBA.Mid$(L, StrLen + 1 - i, 1)) - 64) * 26 ^ (i - 1)
Next
N2Char26R = n
End Function
Function N2Char26(ByVal L As Double) As String
Dim iMod As Integer, dInt As Double, dNum As Double, sChar As String
dInt = VBA.Int(L / 26)
iMod = L - dInt * 26
Do While dInt > 0
sChar = VBA.Chr$(64 + IIf(iMod = 0, 26, iMod)) & sChar
dNum = dInt
dInt = VBA.Int(dInt / 26)
iMod = dNum - dInt * 26
Loop
If L > 26 Then sChar = VBA.Chr$(64 + IIf(iMod = 0, 26, iMod)) & sChar
N2Char26 = sChar
End Function

复制代码

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

蓝桥玄霜 · 发表于 2009-9-20 13:59

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

收到 ——ldy

'论坛ID: 蓝桥玄霜 OK +3
'第16楼
Function N2Char26R(ByVal L As String) As Double
Dim a$, b, suz#, n&, i&
Const zm = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
L = UCase(L)
For i = Len(L) To 1 Step -1
a = Mid$(L, i, 1)
b = InStr(zm, a)
suz = suz + b * 26 ^ n
n = n + 1
Next i
N2Char26R = suz
End Function
Function N2Char26(ByVal L As Double) As String
Dim iMod As Integer, dInt As Double, sChar As String
Dim di#, n%
Const zd = 2147483647
Const el = 26
dInt = L
Do While dInt > zd
n = n + 1
If n Mod 2 = 1 Then
di = Int(dInt / el) * el
iMod = dInt - di
dInt = di
If iMod = 0 Then
dInt = dInt - 1
sChar = "Z"
Else
sChar = Chr(iMod + 64) & sChar
End If
ElseIf Int(dInt / el) > zd Then
dInt = Int(dInt / el)
di = Int(dInt / el)
iMod = dInt - di * el
dInt = di
If iMod = 0 Then
dInt = dInt - 1
sChar = "Z"
Else
sChar = Chr(iMod + 64) & sChar
End If
Else
dInt = Int(dInt / el)
GoTo 100
End If
Loop
iMod = dInt Mod el
dInt = Int(dInt / el)
If iMod > 0 Then
sChar = Chr(iMod + 64) & sChar
ElseIf dInt > 0 Then
dInt = dInt - 1
sChar = "Z"
End If
100:
Do While dInt > 0
iMod = dInt Mod el
dInt = Int(dInt / el)
If iMod > 0 Then
sChar = Chr(iMod + 64) & sChar
Else
dInt = dInt - 1
sChar = "Z" & sChar
End If
Loop
N2Char26 = sChar
End Function

复制代码

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

incognito · 发表于 2009-9-20 14:24

占位
邮件已经发送，请查收

[ 本帖最后由 incognito 于 2009-9-20 14:31 编辑 ]

收到 ——ldy

'Excel Home ID: incognito Ok +3 -1
'
Function N2Char26r(ByVal L As String) As Double
Dim Ltr As String
Dim Catch As String
Dim F As Integer
Dim J As Integer
Dim n As Integer
L = UCase(L)
If Not IsNumeric(L) Then
Begin_Proc:
If Len(L) < 2 Then
N2Char26r = Asc(L) - 64
Else
J = Len(L)
For n = 1 To Len(L)
Ltr = Mid(L, n, 1)
Catch = Catch & Ltr
If Not IsNumeric(Ltr) Then
N2Char26r = N2Char26r + ((Asc(Ltr) - 64) * (26 ^ (J - n)))
Else
L = Catch
GoTo Begin_Proc
End If
Next n
End If
Else
N2Char26r = CInt(L)
Exit Function
End If
End Function
Function N2Char26(ByVal L As Double) As String
Dim CumSum As Variant, InputValue As Variant
Dim StringPosition As Integer
Dim i As Integer, Modulus As Integer
Dim TempString As String, PartialValue As Variant
On Error GoTo Err_N2Char26
InputValue = CDec(L)
If InputValue < 1 Then
N2Char26 = ""
Else
StringPosition = 0
CumSum = CDec(0)
TempString = ""
Do
PartialValue = Int(CDec((InputValue - CumSum - 1) / (26 ^ StringPosition)))
Modulus = PartialValue - Int(CDec(PartialValue / 26)) * 26
TempString = Chr(Modulus + 65) & TempString
StringPosition = StringPosition + 1
CumSum = CDec(0)
For i = 1 To StringPosition
CumSum = CDec((CumSum + 1) * 26)
Next i
Loop While InputValue > CumSum
N2Char26 = TempString
End If
Exit Function
'邮件内容到此为止，下面两行是我手工添加的，扣 1 分
Err_N2Char26:
End Function

复制代码

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

joforn · 发表于 2009-9-21 11:43

好久没参加了，这次参与下。

不过有点担心版主的邮箱又把我的邮箱地址屏蔽掉了

，前几次每次都收不到我的邮件

请将N2Char26中的
dInt = CDbl(Split(Format(L / 26, "0.0000000000000000000000"), ".")(0))
改为dInt =Fix(L / 26) ，一直把Fix和int记成不能返回大于Long能表示的最大数的Double

当然，这两种写法在这里的运行结果是一样的，不过下一写法更明了直接

[ 本帖最后由 joforn 于 2009-9-21 12:04 编辑 ]

收到 ——ldy

'论坛ID：Joforn Ok +3
Function N2Char26R(ByVal L As String) As Double
'你的代码要求EXCEL2003下可运行
'要求不仅限于 2003的IV（256) 和 2007 的XFD（16384列）
'具体要求请运行验证1
Dim byteD() As Byte, I As Long
Dim dNum As Double
On Error GoTo N2Char26R_Error
If Len(L) Then
byteD = StrConv(StrConv(L, vbUpperCase), vbFromUnicode)
For I = LBound(byteD) To UBound(byteD)
Select Case byteD(I) '这个主要是判断输入的字符串是否合法，如果只考虑速度或是能保证输入正确性可直接去除。
Case &H41 To &H5A: dNum = dNum * 26# + byteD(I) - &H40
Case Else: Exit Function
End Select
Next I
Erase byteD
End If
N2Char26R = dNum
N2Char26R_Error:
End Function
Function N2Char26(ByVal L As Double) As String
'你的代码要求EXCEL2003下可运行
'具体要求请运行验证2
Const maxLen As Long = 255 '不用太大，实际上大于217位时Double已经溢出了。
Dim byteD() As Byte, I As Long
Dim lMod As Long, dInt As Double
If L < 1 Then Exit Function
I = -1: ReDim byteD(maxLen)
Do While L
If L > 2147483647 Then
I = I + 1
' dInt = CDbl(Split(Format(L / 26, "0.0000000000000000000000"), ".")(0)) '去小数部分，0多只是为了防止0.9999999这种变态小数
dInt = Fix(L / 26)
lMod = L - dInt * 26#
If lMod Then
byteD(I) = lMod + &H40
L = dInt
Else
byteD(I) = &H5A
L = dInt - 1
End If
Else
'其实直接用上面的循环也可以，不过速度会慢点,好像达不到比原函数快一倍的要求^_^
Do While L
I = I + 1
lMod = L Mod 26
If lMod Then
byteD(I) = lMod + &H40
L = L \ 26
Else
byteD(I) = &H5A
L = L \ 26 - 1
End If
Loop
End If
Loop
If I >= 0 Then
ReDim Preserve byteD(I)
N2Char26 = StrReverse(StrConv(byteD, vbUnicode))
End If
End Function

复制代码

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

northwolves · 发表于 2009-9-21 13:38

好久没积分了，凑个热闹。邮件已发，刘兄请查收

收到 ——ldy

'论坛ID：Northwolves 26的整倍数验证未通过（26=AZ) +1
Function N2Char26R(ByVal L As String) As Double
Dim i As Long, n As Long, r As Double
L = UCase(StrReverse(L))
n = Len(L)
For i = 1 To n
r = r + (Asc(Mid(L, i, 1)) - 64) * 26 ^ (i - 1)
Next
N2Char26R = r
End Function
Function N2Char26(ByVal L As Double) As String
Dim t As Double, s As String, v As String, n As Long
t = L
While t > 0
v = "Z"
n = t - 26 * Int(t / 26)
If n Then v = Chr(n + 64)
s = v & s
t = Int(t / 26)
Wend
N2Char26 = s
End Function

复制代码

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

HHAAMM · 发表于 2009-9-21 20:41

邮件已发送，请刘版查收，多谢。

收到 ——ldy

'论坛ID：HHAAMM Ok +3
' dInt = Int(L / 26.00000000001)
'用这个来处理 26整倍数的问题，很不错。
Function N2Char26R(ByVal L As String) As Double
Dim a() As Byte, m As Double, i%, j%, t%
a = UCase(L)
j = UBound(a)
t = (UBound(a) + 1) / 2 - 1
For i = 0 To j Step 2
m = m + (a(i) - 64) * 26 ^ t
t = t - 1
Next
N2Char26R = m
End Function
Function N2Char26(ByVal L As Double) As String
Dim m As Double, iMod As Integer, dInt As Double, sChar As String
m = L
dInt = Int(L / 26.00000000001)
iMod = m - dInt * 26
sChar = Chr(iMod + 64)
Do While dInt > 0
m = dInt
dInt = Int(m / 26.00000000001)
iMod = m - dInt * 26
sChar = Chr(iMod + 64) & sChar
Loop
N2Char26 = sChar
End Function

复制代码

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

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

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

邮件已发，楼主查收！

评分

评分

评分

评分

评分

评分

评分

评分

评分

本帖子中包含更多资源

评分