对“在EXCEL中如何使用VBA进行格式转化”的改进算法
来源：互联网 发布：cad套料软件 编辑：程序博客网 时间：2024/05/17 23:43
对“在EXCEL中如何使用VBA进行格式转化”的改进算法
在在EXCEL中如何使用VBA进行格式转化中，我们简单的讨论了如何用VBA实现十六进制、十进制、八进制和二进制之间的转化。对于简单的小数运用，它工作良好，但是它有先天的缺陷：
ü 对于一些复杂的且带有前缀的格式，它无能为力。比如说，” – 345 FABC KK WW”转化为十进制数的应用，等
ü 对于一些大数，它超过Long（32位）的取值范围，它将无法进行准确的转化。
ü 把所有的运算堆积于一个函数，日后难以维护。
ü 过多的字符串拷贝操作，效率较低。
ü 无法动态的改变格式转化的值域，比如现有代码能够通过改变WYQ_FORMAT_BITS的值来进行一定的调整。
基于上述的缺陷，作者对其进行了改进工作，现有的代码如下：
'History
'07/02/2008:
'-Add WYQConvert() and WYQXor() functions
'07/03/2008:
'-Check the parameter of WYQConvert() to robust it. If dstBase is not checked, the deadloop maybe
' is occur when its value smaller than 2.
'07/04/2008:
'-Add WYQGetValue() and WYQGetString() to simplfy the source code
'07/05/2008:
'-Add WYQGetPrefixLength(), WYQGetPrefixSpaces() and WYQGetSignLength() to parse the complicated format
Option Explicit
'------------------------------------------------------------------------------------------'
' Public Const Values '
'------------------------------------------------------------------------------------------'
Public Const WYQ_FORMAT_BITS As Long = 32
Public Const WYQ_FORMAT_BYTES As Long = (WYQ_FORMAT_BITS / 8)
Public Const WYQ_FORMAT_STR As String = "" & (2 ^ (WYQ_FORMAT_BITS - 1))
Public Const WYQ_FORMAT_VAL_MAX As Double = (2 ^ WYQ_FORMAT_BITS)
'------------------------------------------------------------------------------------------'
' Public External Functions '
'------------------------------------------------------------------------------------------'
Public Function WYQConvert(ByRef srcData As String, ByVal srcBase As Integer, ByVal dstBase As Integer) As String
Dim prefixLen As Integer
Dim signLen As Integer
Dim positive As Integer
Dim length As Integer
Dim value As Double
Dim rs As String
'Check whether the base of destination is valid
If srcBase < 2 Or dstBase < 2 Then
WYQConvert = Null
Exit Function
End If
'Check whether the formats are same between source and destination
'If srcBase = dstBase Then
' WYQConvert = srcData
' Exit Function
'End If
'Acquire the length of string
length = Len(srcData)
'Acquire the lenght of prefix character
prefixLen = WYQGetPrefixLength(srcData, 0, length, srcBase)
'MsgBox "Prefix length = " & prefixLen
'Check the returning value
If prefixLen < 0 Then
WYQConvert = Null
Exit Function
End If
'Acquire the length of sign
signLen = WYQGetSignLength(srcData, prefixLen, length, srcBase, positive)
'MsgBox "Sign length = " & signLen
'Check the returning value
If signLen < 0 Then
WYQConvert = Null
Exit Function
End If
'Convert String to Long in the light of decimal system
value = WYQGetValue(srcData, prefixLen + signLen, length, srcBase)
'MsgBox "Value = " & value
'Check whether value is negative and acquire the complement value
If positive = 0 Then
If srcBase = 10 Or dstBase = 10 Then
If srcBase <> dstBase Then
'Acquire the complement value
value = WYQ_FORMAT_VAL_MAX - value
End If
End If
End If
'Convert Long to String in the light of requesting base
rs = WYQGetString(value, dstBase)
'Add negative symbol when it is decimal
If positive = 0 And dstBase = 10 And rs <> "0" Then
rs = "-" & rs
End If
'MsgBox "Result = " & rs
WYQConvert = rs
End Function
'------------------------------------------------------------------------------------------'
' Private Internal Functions '
'------------------------------------------------------------------------------------------'
Private Function WYQGetValue(ByRef strData As String, ByVal offset As Integer, ByVal length As Integer, ByVal base As Integer) As Double
Dim idx As Integer
Dim size As Integer
Dim mask As Integer
Dim tmp As Integer
Dim value As Double
Dim s As String
'Assign the default value for mask
mask = -1
'Tailor the proper length in the light of base
Select Case base
Case Is = 10
size = Len(WYQ_FORMAT_STR)
Case Else
Dim power As Integer
Dim units As Integer
Dim chars As Integer
power = Fix(Log(base) / Log(2))
units = (WYQ_FORMAT_BITS + power - 1) / power
chars = length - offset
If chars > units Then
chars = 0
'Calculate the real characters except for blank space
For idx = (offset + 1) To length
s = Mid(strData, idx, 1)
If s <> " " Then
chars = chars + 1
End If
If chars = units Then
'Characters are enough
Exit For
End If
Next
'Decrease the length in the light of idx
length = idx
End If
'Check whether chars are enough
If chars = units Then
Dim bits As Integer
bits = WYQ_FORMAT_BITS Mod power
If bits > 0 Then
mask = (2 ^ bits)
End If
End If
size = units
End Select
value = 0
For idx = (offset + 1) To length
s = Mid(strData, idx, 1)
Select Case s
Case "0" To "9"
tmp = CInt(s)
Case Is = "A"
tmp = 10
Case Is = "a"
tmp = 10
Case Is = "B"
tmp = 11
Case Is = "b"
tmp = 11
Case Is = "C"
tmp = 12
Case Is = "c"
tmp = 12
Case Is = "D"
tmp = 13
Case Is = "d"
tmp = 13
Case Is = "E"
tmp = 14
Case Is = "e"
tmp = 14
Case Is = "F"
tmp = 15
Case Is = "f"
tmp = 15
Case Is = " "
'Ignore the blank space
tmp = -1
Case Else
tmp = base
End Select
If tmp >= base Then
Exit For
End If
If tmp >= 0 Then
If size < 1 Then
Exit For
End If
size = size - 1
'Keep the partial bits for the first value
If mask >= 0 Then
tmp = tmp Mod mask
mask = -1
End If
value = value * base + tmp
End If
Next
WYQGetValue = value
End Function
Private Function WYQGetString(ByVal doubleValue As Double, ByVal base As Integer) As String
Dim remain As Double
Dim multi As Double
Dim s As String
Dim rs As String
rs = ""
doubleValue = Fix(doubleValue)
While doubleValue > 0
multi = Fix(doubleValue / base)
remain = doubleValue - multi * base
doubleValue = multi
Select Case remain
Case 0 To 9
s = "" & remain 'Trim(str(remain))
Case Is = 10
s = "A"
Case Is = 11
s = "B"
Case Is = 12
s = "C"
Case Is = 13
s = "D"
Case Is = 14
s = "E"
Case Is = 15
s = "F"
End Select
rs = s & rs
Wend
'Check whether value equals zero to assign the proper value
If rs = "" Then
rs = "0"
End If
WYQGetString = rs
End Function
Private Function WYQGetPrefixLength(ByRef strData As String, ByVal offset As Integer, ByVal length As Integer, ByVal base As Integer) As Integer
Dim prefix As String
Dim idx As Integer
Dim prefixLen As Integer
'Calculate the number of prefix blank spaces
prefixLen = WYQGetPrefixSpaces(strData, offset, length)
'Check whether there are no characters in the string
If prefixLen = length Then
WYQGetPrefixLength = prefixLen
Exit Function
End If
'Acquire first non blank space
prefix = UCase(Mid(strData, offset + prefixLen + 1, 1))
'MsgBox "Prefix = " & prefix
'Eliminate the prefix if it exists
Select Case base
Case Is = 16
'Eliminate the prefix, such as 0x, x, 0X, X, h, H, &h, &H
If prefix = "X" Or prefix = "H" Then
prefixLen = prefixLen + 1
ElseIf prefix = "0" Or prefix = "&" Then
prefix = UCase(Mid(strData, offset + prefixLen + 1, 2))
Select Case prefix
Case Is = "0X"
prefixLen = prefixLen + 2
Case Is = "&H"
prefixLen = prefixLen + 2
Case "00" To "0F"
Case Else
prefixLen = -1
End Select
Else
'Here, code can check whether character is valid
End If
Case Is = 10
'Eliminate the prefix, such as d, D, &d, &D
If prefix = "D" Then
prefixLen = prefixLen + 1
ElseIf prefix = "&" Then
prefix = UCase(Mid(strData, offset + prefixLen + 1, 2))
If prefix = "&D" Then
prefixLen = prefixLen + 2
Else
prefixLen = -1
End If
Else
'Here, code can check whether character is valid
End If
Case Is = 8
'Eliminate the prefix, such as o, O, &o, &O
If prefix = "O" Then
prefixLen = prefixLen + 1
ElseIf prefix = "&" Then
prefix = UCase(Mid(strData, offset + prefixLen + 1, 2))
If prefix = "&O" Then
prefixLen = prefixLen + 2
Else
prefixLen = -1
End If
Else
'Here, code can check whether character is valid
End If
Case Is = 2
'Eliminate the prefix, such as b, B, &b, &B
If prefix = "B" Then
prefixLen = prefixLen + 1
ElseIf prefix = "&" Then
prefix = UCase(Mid(strData, offset + prefixLen + 1, 2))
If prefix = "&B" Then
prefixLen = prefixLen + 2
Else
prefixLen = -1
End If
Else
'Here, code can check whether character is valid
End If
Case Else
'There are not any prefix characters
End Select
If prefixLen >= 0 Then
'Eliminate the spaces after prefix characters
prefixLen = prefixLen + WYQGetPrefixSpaces(strData, offset + prefixLen, length)
'Check whether there are no characters in the string
If prefixLen = length Then
prefixLen = -1
End If
End If
WYQGetPrefixLength = prefixLen
End Function
Private Function WYQGetPrefixSpaces(ByRef strData As String, ByVal offset As Integer, ByVal length As Integer) As Integer
Dim size As Integer
size = 0
For offset = (offset + 1) To length
If Mid(strData, offset, 1) <> " " Then
Exit For
End If
size = size + 1
Next
WYQGetPrefixSpaces = size
End Function
Private Function WYQGetSignLength(ByRef strData As String, ByVal offset As Integer, ByVal length As Integer, ByVal base As Integer, ByRef positive As Integer) As Integer
Dim size As Integer
Dim value As Integer
Dim s As String
'Assign the default sign
positive = 1
'Acquire the number of prefix blank spaces
size = WYQGetPrefixSpaces(strData, offset, length)
'Check whether offset is out of range
If (offset + size) >= length Then
WYQGetSignLength = -1
Exit Function
End If
'Acquire the next character
s = UCase(Mid(strData, (offset + size + 1), 1))
'MsgBox "s = " & s
'Check whether format is decimal
Select Case base
Case Is = 10
If s = "+" Then
size = size + 1
ElseIf s = "-" Then
positive = 0
size = size + 1
Else
'Here, code can check whether character is valid
End If
'Eliminate the blank space after "+" or "-"
size = size + WYQGetPrefixSpaces(strData, (offset + size), length)
Case Else
'Acquire the value of character
Select Case s
Case "0" To "9"
value = CInt(s)
Case Is = "A"
value = 10
Case Is = "B"
value = 11
Case Is = "C"
value = 12
Case Is = "D"
value = 13
Case Is = "E"
value = 14
Case Is = "F"
value = 15
Case Else
value = base
End Select
'Check whether the value is out of range
If value >= base Then
'There are invalid character in the string
size = -1
Else
Dim power As Integer
Dim units As Integer
Dim chars As Integer
power = Fix(Log(base) / Log(2))
units = (WYQ_FORMAT_BITS + power - 1) / power
chars = length - offset - size
If chars > units Then
Dim idx As Integer
chars = 0
'Calculate the real characters except for blank space
For idx = (offset + size + 1) To length
s = Mid(strData, idx, 1)
If s <> " " Then
chars = chars + 1
End If
If chars = units Then
'Characters are enough
Exit For
End If
Next
'Decrease the length in the light of idx
length = idx
End If
'Check whether chars are enough
If chars = units Then
Dim bits As Integer
Dim threshold As Integer
bits = WYQ_FORMAT_BITS Mod power
If bits = 0 Then
threshold = (2 ^ (power - 1))
value = value Mod base
Else
threshold = (2 ^ (bits - 1))
value = value Mod (2 ^ bits)
End If
If value >= threshold Then
positive = 0
End If
End If
End If
End Select
'MsgBox "Positive = " & positive & ", value = " & value & ", threshold = " & threshold
WYQGetSignLength = size
End Function
因为笔者对VBA仅仅无系统性的学习了3天（通过VB的自带帮助），所以可能很多地方做了无谓的实现（比如说，存在系统函数调用就可以实现），但是对于初学者而已，这个可能也算是一个实践的机会吧。随着学习的深入，日后如果发现有更好，更安全简介的方法，我将总结后和大家分享。当然，我希望那些VBA的老鸟，能够和蔼的给出更好，更专业的实现方法。我将不胜感谢！
- 对“在EXCEL中如何使用VBA进行格式转化”的改进算法
- 在EXCEL中如何使用VBA进行格式转化
- 使用Excel+VBA对网页进行操作
- Excel——如何使用VBA操作单元格的格式
- 在excel中如何增加组合框──EXCEL VBA的使用
- 在excel中如何增加组合框──EXCEL VBA的使用
- 不引用word,excel的dll使用反射来在项目中进行vba操作
- 在Excel VBA中如何能够使用ADODB对象？
- 如何在Excel中将文件大小中有GB、MB的信息转化成统一格式
- Excel中VBA的使用
- excel中VBA的使用
- 使用VBA对Excel中列名称与列号之间进行转换
- [Excel VBA] 在VBA中如何将SQL得到的数据直接赋值到数组？
- 利用VBA对提取excel中字母、数字进行提取
- excel VBA对特定背景颜色的单元格进行赋值
- 在VBA中引用excel的函数
- 如何在VB中打开一个Excel文件并调用Excel文件自身的VBA宏？
- SQL中使用CONVERT函数对时间数据类型进行格式转化
- 条形码技术应用分析
- 算法设计的过程
- Apache 错误记录
- jBPM学习（一）----环境搭建
- 推荐一些歌曲
- 对“在EXCEL中如何使用VBA进行格式转化”的改进算法
- 基于规则的业务流程分析
- Javascript中最常用的55个经典技巧
- ubuntu下修改grub的引导顺序（windows和ubuntu双系统）
- link函数
- 回家
- Windows SharePoint Services Version Comparison
- [FreeMarker]FreeMaker+Spring MVC（转）
- 如何安装Eclipse插件(Plug-in) Visual Editor
