|
|
含有字符串变量的公式运算(Ahua原创)v103-vba.zip
(25.07 KB, 下载次数: 105)
'含有字符串变量的公式运算(Ahua原创)v102-vba
'strNg = "-a+6*(1+b-3)" '赋值
'patrn = "[-+*/()]" '定义正则表达式，匹配这些 -+*/() 符号
'*************************************************************************
'**说 明：南航深圳公司后勤保障部 版权所有2009 - 2010(C)1
'**创 建 人：李君华 QQ215954409
'**日 期：2009-03-08 23:01:11
'**描 述：含有字符串变量的公式运算
'**版 本：V1.0.2
'*************************************************************************
'2009-03-08 23:01:11修正了:从集合中提取算术符，并分解字符串公式存入数组
'声明Excel变量
Public xlApp As Excel.Application
Public xlBook As Excel.Workbook
Public xlSheet As Excel.Worksheet
Dim Matches As Object '声明集合
Private Carray() As String '声明数组为全局变量'正则表达式在字符串找到指定字符并存入二维数组
Sub 示例()
With Worksheets(1)
For i = 5 To 20
文本公式 = .Cells(i, 2)
If 文本公式 = "" Then Exit For
.Cells(i, 3) = 计算(文本公式)
Next
End With
End Sub
Function 计算(文本公式)
Dim StrsN() 'As String
Dim strNg As String, patrn As String
Dim i As Integer
Dim pos As Integer
'strNg = "(63+(1+32))-a+((b+a+d+a+c+b))" '示例，赋值 其中a、b可为任何字符串
strNg = 文本公式
If strNg = "" Then MsgBox "Err": Exit Function
patrn = "[-+*/()]" '定义正则表达式，匹配这些 -+*/()符号
strNgTemp = strNg '临时存放，用于替换操作
Call RegExpTest(patrn, strNg)
'初始值
算术符PosBF = 1 '算术符位置初始值
i = 0 'Carray()上标的初始值
i3 = 0 'StrsN()上标的初始值
算术符gs = Matches.Count '算术符个数
strNgLen = Len(strNg) '算术表达式长度
'从集合中提取算术符，并分解字符串公式存入数组
For Each Match In Matches ' 遍历 Matches 集合。
'位置=Match.FirstIndex '找到的字符=Match.value
算术符Pos = Match.FirstIndex + 1 '位置
算术符str = Match.Value '找到的算术符
n = 算术符Pos - 算术符PosBF '两个算术符间字符个数
200
'算术表达符不在No.1个位置;n>0两个算术符间字符个数>0,则中间有字符串
'writeEnd = True (Matches.Count = i And strNgLen > 算术符Pos) 最后一个为字符串
If (算术符Pos > 1 And n > 0) Or writeEnd = True Then
strS = Trim(Mid(strNg, 算术符PosBF, n)) '取出算术符号间的字符，并去掉前后空格
'存入数组
ReDim Preserve Carray(0 To 2, 0 To i) '定义数组的维数3，strFindGs变量不能放在前面，只能放在后面
Carray(0, i) = IIf(IsNumeric(strS) = False, "字符串", "数字符")
Carray(1, i) = IIf(i = 0, 算术符Pos - 1, 算术符Pos - n) '
Carray(2, i) = strS
Debug.Print Carray(0, i) & " " & Carray(1, i) & " " & Carray(2, i)
i = i + 1: writeTF = True
End If
If writeEnd = True Then GoTo 300 '最后一个完成
'算术表达符在No.1个位置,如"-(";n = 0为算术表达符;算术符Pos = strNgLen 最后一个字符为算术符
If 算术符Pos = 1 Or n = 0 Or 算术符Pos = strNgLen Or writeTF = True Then
'存入数组
ReDim Preserve Carray(0 To 2, 0 To i) '定义数组的维数3，strFindGs变量不能放在前面，只能放在后面
Carray(0, i) = IIf(算术符str = "(" Or 算术符str = ")", "括号", "算术符") '类型 (字符串,算术符)
Carray(1, i) = 算术符Pos '位置 (1-?)
Carray(2, i) = 算术符str '找到的字符
Debug.Print Carray(0, i) & " " & Carray(1, i) & " " & Carray(2, i)
i = i + 1: writeTF = False
If n = 0 And posNo1 = 1 Then posNo1 = 算术符Pos + 1 '保存，作为下一次计算起始位;表示连续出现两个以上算术符
End If
算术符PosBF = Match.FirstIndex + 2 '位置备份
Next
If strNgLen > 算术符Pos Then
n = strNgLen - 算术符Pos
writeEnd = True
算术符Pos = strNgLen + 1
GoTo 200
End If
300
'遍历Carray 3维数组
x = LBound(Carray, 2): y = UBound(Carray, 2)
For i = LBound(Carray, 2) To UBound(Carray, 2) '得到数组上标下标, + 1 表示公式中字符比算术符多一个
StrTypeTemp = Carray(0, i) '取出字符类型
StrTemp = Carray(2, i) '取出字符
Debug.Print "取出字符类型" & StrTypeTemp & " " & StrTemp
If (Not StrTypeTemp = "字符串") Or StrTemp = "" Then GoTo 400
'是否为字符
If IsNumeric(StrTemp) = False And StrTemp <> "" Then
ReDim Preserve StrsN(0 To 2, 0 To i3) '定义数组的维数3，i2变量不能放在前面，只能放在后面
'检查数组中是否以经包含这个字符
For i2 = LBound(StrsN, 2) To UBound(StrsN, 2) '遍历数组
If StrTemp = StrsN(0, i2) Then GoTo 100 '存在跳出
Next
'查找
FindStrTemp = FindStr(StrTemp)
'替换
strNgTemp = Replace(strNgTemp, StrTemp, FindStrTemp) '字符替换成数字
'把找到的字符存入TempTh()数组
StrsN(0, i3) = StrTemp '写入找到的字符
StrsN(1, i3) = FindStrTemp '写入找到的字符值
StrsN(2, i3) = "" '写入找到的字符在字符串中的起始位置
i3 = i3 + 1
100 End If
400 Next i
' '打印出数组
' For i3 = LBound(StrsN, 2) To UBound(StrsN, 2)
' strone11 = StrsN(0, i3) '取列1 字符
' num11 = StrsN(1, i3) '取列2
' posf11 = StrsN(2, i3) '取列3 位置
'
' If strone11 = "" Then Exit For
' Debug.Print strone11 & "=" & num11 & "位置在:" & posf11
'
' Next
Erase Carray() '清空数组
Erase StrsN()
'Path = App.Path & "\" & "text.xls" 'vb
'Path = ThisWorkbook.Path & "\" & "text.xls" 'vba
'If IsOpen(Path) = True Then Call CloseExcel
计算 = Cal(strNgTemp)
Debug.Print strNg & "=" & 计算
Debug.Print strNgTemp & "=" & 计算
End Function
'使用正则表达式搜索字符串中匹配的位置,并存入二维数组
'使用了正则表达式，工程-引用-Microsoft VBScript Regular Expressions 5.5打钩-确定
Function RegExpTest(patrn, strNg) As String() 'As String() 作用为Function返回Carray()数组
Dim regEx, Match ', Matches ' 建立变量。
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern = patrn ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分大小写。
regEx.Global = True ' 设置全局可用性。
Set Matches = regEx.Execute(strNg) ' 执行搜索，并把搜索到的目标存入Matches。
End Function
'把字符串表达式转换并计算
'如果你的工程没有引用Script,需要引用
'工程-〉部件-“Microsoft Script Control”打钩-确定
Private Function Cal(strS)
Dim s2 As Object
Set s2 = CreateObject("MSScriptControl.ScriptControl")
s2.Language = "VBScript"
Cal = s2.Eval(strS) '转换计算
Set s2 = Nothing
End Function
'*************************************************************************
'**函 数 名：FindStr
'**输 入：strS
'**输 出：无
'**功能描述：从Excel中查找出字符串变量相应的值
'**全局变量：
'**调用模块：
'*************************************************************************
Private Function FindStr(strS)
' 'Path = App.Path & "\text.xls" 'vb
' Path = ThisWorkbook.Path & "\text.xls" 'vba
' Call OpenExcel(Path)
'
' '在 另一个Excel文档中查找
' With xlSheet.Range("a1:a100")
' If Not .Find(strS, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
' pos = .Find(strS, LookIn:=xlValues, LookAt:=xlWhole).Address '坐标
' 'StrTemp1 = Left(pos, InStr(2, pos, "$")) '$A$
' StrTemp2 = Right(pos, Len(pos) - InStr(2, pos, "$")) '1
' StrTemp3 = Chr(Val(Asc(Mid(pos, 2, InStr(2, pos, "$") - 2)) + 2)) 'C
' FindStr = xlSheet.Range(StrTemp3 & StrTemp2)
' End If
' End With
'在当前工作表中查找
With Worksheets(2).Range("a1:a100")
If Not .Find(strS, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
pos = .Find(strS, LookIn:=xlValues, LookAt:=xlWhole).Address '坐标
'StrTemp1 = Left(pos, InStr(2, pos, "$")) '$A$
StrTemp2 = Right(pos, Len(pos) - InStr(2, pos, "$")) '1
StrTemp3 = Chr(Val(Asc(Mid(pos, 2, InStr(2, pos, "$") - 2)) + 1)) '获取值所在的列 B
FindStr = Worksheets(2).Range(StrTemp3 & StrTemp2) '获取值
End If
End With
End Function
'"工程"菜单中选择"引用"栏；选择Microsoft Excel 9.0 Object Library（EXCEL2000），然后选择"确定"。表示在工程中要引用EXCEL类型库。
Public Sub OpenExcel(Path)
If IsOpen(Path) = False And FileYN(Path) = True Then
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(Path)
Set xlSheet = xlBook.Worksheets(1)
xlApp.Visible = False '设为false，不可见
End If
End Sub
Public Sub CloseExcel()
xlBook.Close (False)
xlApp.Application.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
'检查一个文件是否被打开?
Private Function IsOpen(sFile) As Boolean
Dim fFile As Integer
fFile = FreeFile()
On Error GoTo ErrOpen
Open sFile For Binary Lock Read Write As fFile
Close fFile
Exit Function
ErrOpen:
If Err.Number <> 70 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
Else
IsOpen = True
End If
End Function
'Excel文件是否存在
Public Function FileYN(FilePathName)
Dim yyy
Set yyy = CreateObject("Scripting.FileSystemObject")
'If yyy.FolderExists(FileNamePath) = False Then MkDir FileNamePath '文件夹不存在，新建
If yyy.FileExists(FilePathName) = False Then '文件是否存在
MsgBox "文件不存在"
End If
FileYN = True
Set yyy = Nothing
End Function
'end
'从Excel中查找出字符串变量相应的值
'----------------------------------------------------------------------------
|
评分
-
1
查看全部评分
-
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2012-8-16 12:22
楼主
