hiermit gehts
19.09.2009 21:36:02
Stefan
Hallo ransi und alle anderen
mit folgendem Code funzt es
Besten Gruß
Stefan
Option Explicit
Option Base 1
Public Function AnzeigeFormel(x)
'Hinweis:
'mehrere Formel ergänzen in einer Zelle
' =AnzeigeFormel(ZS)&" + "&AnzeigeFormel(ZS)
' also mit & am Ende der Ersten und & am Anfang der Zweiten
Dim CallerSheet As String, CallerBook As String
Dim OriFor As String, FormularLen As Integer
Dim MathOp As Variant, I As Integer
Dim SearchStart As Integer, K As Integer
Dim SwapOp As Boolean, LastK As Integer
Dim CellAdd As String, Genfor As String, GenOpt As String
Dim Variable As Variant
Dim Bf As String, Md As String, Af As String
Static AlreadyOpen As Boolean
'Dim MyCell As Object, GetCaller As String
'Set MyCell = Application.Caller
'GetCaller = Str$(a) + "+" + Str$(b)
'GetCaller = MyCell.Address
'GetCaller = MyCell.Parent.Name
'GetCaller = MyCell.Worksheet.Name
'Application.Volatile
CallerSheet = Application.Caller.Parent.Name
CallerBook = Application.Caller.Parent.Parent.Name
'Print #1, "Main-->"; ActiveSheet.Name
MathOp = Array("=", "+", "-", "*", "/", "^", ",", ":")
OriFor = x.Formula
FormularLen = Len(OriFor)
ReDim Operator(FormularLen) As Integer
If Left$(OriFor, 1) "=" Then
OriFor = "=" + OriFor
FormularLen = FormularLen + 1
End If
'Replace ":\" with "|\"
SearchStart = 1
Do While InStr(SearchStart, OriFor, ":\") > 0
K = InStr(SearchStart, OriFor, ":\")
Mid$(OriFor, K, 2) = "|\"
SearchStart = SearchStart + 1
Loop
K = 1
For I = 1 To 8 '8 math operators (include ',' and ':')
SearchStart = 1
Do While InStr(SearchStart, OriFor, MathOp(I)) > 0
Operator(K) = InStr(SearchStart, OriFor, MathOp(I))
SearchStart = Operator(K) + 1
K = K + 1
Loop
Next I
Operator(K) = FormularLen + 1
LastK = K
'Sort Operator()
Do
SwapOp = False
For I = 1 To LastK - 1
If Operator(I) > Operator(I + 1) Then
'swap Operator(I), Operator(I + 1)
K = Operator(I)
Operator(I) = Operator(I + 1)
Operator(I + 1) = K
SwapOp = True
End If
Next I
Loop Until SwapOp = False
Genfor = ""
For I = 1 To LastK - 1
CellAdd = Mid$(OriFor, Operator(I) + 1, Operator(I + 1) - Operator(I) - 1)
GenOpt = Mid$(OriFor, Operator(I), 1)
Call CheckBK(CellAdd, Bf, Md, Af)
GenOpt = GenOpt + Bf
CellAdd = Md
If CellAdd "" Then
FormularLen = Len(CellAdd)
' For K = 1 To FormularLen
' Next K
Call ObtainValue(CellAdd, CallerSheet, CallerBook, Variable)
Else
Variable = ""
End If
Select Case GenOpt
Case Is = ":"
GenOpt = " to "
'GenOpt = "->"
'Case Is = "*"
' GenOpt = "x"
End Select
Genfor = Genfor + GenOpt + Variable + Af
Next I
'Set supercript
Genfor = Right$(Genfor, Len(Genfor) - 1)
Call ReplaceConstant(Genfor)
If Left$(Genfor, 1) = "+" Then
AnzeigeFormel = Right$(Genfor, Len(Genfor) - 1)
Else
AnzeigeFormel = Genfor
End If
'Replace "|\" with ":\"
SearchStart = 1
Do While InStr(SearchStart, AnzeigeFormel, "|\") > 0
K = InStr(SearchStart, AnzeigeFormel, "|\")
Mid$(AnzeigeFormel, K, 2) = ":\"
SearchStart = SearchStart + 1
Loop
End Function
Sub CheckBK(ForStr As String, Bf As String, Md As String, Af As String)
'Check for Brackets ie. '()'
'Bf = before '('
'Md - between '('&')'
'Af -after ')'
Dim I As Integer, K As Integer, L As Integer
Dim Opb As Integer, Clb As Integer
L = Len(ForStr)
K = 0
Do While InStr(K + 1, ForStr, "(") > 0
K = K + 1
Loop
Opb = K
Clb = InStr(1, ForStr, ")")
If Clb = 0 Then Clb = L + 1
Bf = Left$(ForStr, Opb) ': Print "bf="; "@"; Bf$; "@"
Md = Mid$(ForStr, Opb + 1, Clb - Opb - 1) ': Print "md="; "@"; Md$; "@"
Af = Right$(ForStr, L - Clb + 1) ': Print "Af="; "@"; Af$; "@"
End Sub
Sub RmvU(Md)
'Remove unwanted formating in number format string
Dim L As Integer, NewMd As String, I As Integer
Dim TempMd As String
NewMd = ""
L = Len(Md)
For I = 1 To L
TempMd = Mid(Md, I, 1)
Select Case TempMd
Case Is = "?"
'do nothing
Case Is = "_"
I = I + 1
Case Else
NewMd = NewMd + TempMd
End Select
Next I
Md = NewMd
End Sub
Sub ObtainValue(CellAdd, CallerSheet, CallerBook, Variable)
On Error GoTo NonAdd
Dim Md As String
Dim VarAdd As Object
'Print #1, CellAdd, TypeName(Range(CellAdd).Value)
If Asc(Left$(CellAdd, 1)) "$" Then
Variable = CellAdd
'Print #1, "no address ", CellAdd
Else
If InStr(CellAdd, "!") = 0 Then
Set VarAdd = Workbooks(CallerBook).Worksheets(CallerSheet).Range(CellAdd)
Else
Set VarAdd = Range(CellAdd)
End If
'With VarAdd
'Md = TypeName(Worksheets(CallerSheet).Range(CellAdd).Value)
Md = TypeName(VarAdd.Value)
If Md = "Empty" Or Md = "Null" Or Md = "Error" Or Md = "String" Then
Variable = Md
Exit Sub
End If
'Print #1, CellAdd, Range(CellAdd).Value
'Variable = Str$(Range(CellAdd).Value)
'Variable = Str$(Range(CellAdd).Value)
'Md = Worksheets(CallerSheet).Range(CellAdd).NumberFormat
Md = VarAdd.NumberFormat
Call RmvU(Md)
'Print #1, CellAdd
If Md = "General" Then
'Variable = Str$(Worksheets(CallerSheet).Range(CellAdd).Value)
Variable = Str$(VarAdd.Value)
Else
'Variable = Format$(Worksheets(CallerSheet).Range(CellAdd).Value, Md)
Variable = Format$(VarAdd.Value, Md)
End If
'End With
End If
Exit Sub
NonAdd:
Variable = "Address Error"
On Error GoTo 0
End Sub
Sub ReplaceConstant(Genfor)
'Replace PI() with 3.142
Dim I As Integer, L As Integer, K As Integer
L = Len(Genfor)
For I = 1 To L
If InStr(I, Genfor, "PI()") > 0 Then
K = InStr(I, Genfor, "PI()")
Mid$(Genfor, K, 4) = "3.142"
End If
Next I
End Sub