So, habe mich doch entschlossen, das Ganze ...
10.12.2011 03:47:49
Luc:-?
…etwas universeller anzugehen, Oliver,
bin mir aber nicht im Klaren, ob das so in deine Regie passt, denn ich habe eine udFkt geschrieben, die einfache Fälle in deinem Sinne behandeln kann und auch noch etwas mehr. Allerdings geht nicht alles und du kannst am Umfang der und den Anmerkungen zur udFkt wahrscheinl ermessen, welchen Arbeitsaufwand eine Totallösung bedeuten würde. Aber wahrscheinl reicht das jetzt erstmal. Später mal, wenn du alles nachvollziehen kannst, kannst du ja versuchen, das bei Bedarf zu erweitern → einige Hinweise dazu sind ja vorhanden. Das waren jetzt erst mal ca 30-35 Stdd Arbeit.
Option Explicit
Public Enum fxExpMode: fxAllLevRefVals = -2: fxFstLevRefVals _
: fxRefOnly: fxFstLevRefValsResult: fxAllLevRefValsResult: End Enum
Rem UDFkt ermittelt Fml v.Arg1 u.bildet sie m.eingesetzten Arg-Werten ab;
' ws in ds Vs nur Fmln aus 1 Fkt, nicht wtr Fktt u.and Bezüge betrifft!
' Als HptBezugsblatt wird d.Blattbezug v.Arg1 bzw d.aktivBlatt vwendet;
' lokale(dt) Darstellg wird m.Arg2>|30 uU eher als Arg d.XLM-
' Fkt AUSWERTEN vwend als b.Arg3=0. B.dt xlVs wird b.Arg3=1 stets d.lok
' Form gezeigt. D.matrixfmlfäh UDF ist noch weiter ausbaubar u.benötigt
' auch deshb d.Enum-Proz fxExpMode, d.ua perspektiv KonstWerte enthält.
' F-Anz: #NULL! -FmlArg ist komplexer Ausdruck (ggf m.internKlammerg),
' #BEZUG! -FmlArg enth ungült, Ganz-Sp/Zl- bzw nicht nur Adress.
' Vs1.1 -LSr -cd: 20111208 -fpub: 20111210 herber.de -lupd: 20111209n
Function FormHabit(ByVal Bezug As Range, Optional ByVal DarstF As fxExpMode, _
Optional ByVal BerWalsMxKonst As Boolean, _
Optional ByVal BerWalsText As Boolean)
Const fktNEnd$ = "[A-Za-z_0-9]", _
fmlAdrEzVgl$ = "[A-Za-z]*[A-Za-z_0-9]([$A-Z]*#)*", _
fmlAdrLiVgl$ = "[A-Za-z]*[A-Za-z_0-9]([$A-Z]*#[:,][$A-Z]*#)*"
Dim isAdrLi As Boolean, isAdrBer As Boolean, isLokF As Boolean, _
isMxBez As Boolean, isOhneErg As Boolean, isSpAusw As Boolean, _
isSpVek As Boolean, ix As Long, xAnz As Long, zx As Long, _
fmlAdrAnf As Integer, fmlAdrEnd As Integer, fmlKp As Integer, _
arFml() As String, dt As String, fml As String, _
fmLok As String, fmlTmpV As String, st As String, _
fmlAdr, fmlAdrBer, fmlAdrV As Variant, _
ac As Range, berBez As Range, bez As Range, zBez As Range, _
bezSh As Worksheet, hptSh As Worksheet
On Error Resume Next
With Application
If IsError(.Caller) Then 'Arg1 nur als Zeile ODER Spalte mögl!
Else: Set ac = .Caller: isSpAusw = .Rows.Count > 1
End If
dt = .International(xlDecimalSeparator)
st = .International(xlColumnSeparator)
End With
isMxBez = IsArray(Bezug): Set hptSh = Bezug.Parent
If hptSh Is Nothing Then Set hptSh = ActiveSheet
If DarstF fxAllLevRefValsResult Then
DarstF = DarstF Mod 3: isLokF = True
End If
If BerWalsText Then
If BerWalsMxKonst Then
BerWalsText = False: isOhneErg = True
Else: isLokF = isLokF Or CBool(dt = ",")
End If
End If
If isMxBez Then
xAnz = Bezug.Cells.Count: ReDim arFml(xAnz - 1)
For Each bez In Bezug
GoSub ef: arFml(ix) = FormHabit: ix = ix + 1
Next bez
If isSpAusw Then
FormHabit = WorksheetFunction.Transpose(arFml)
Else: FormHabit = arFml
End If
Else: Set bez = Bezug
ef: If bez.HasFormula Or Left(bez, 1) = "=" Then 'Wertet auch FmlText aus!
fml = Mid(bez.Formula, 2)
If isLokF Then fmLok = Mid(bez.FormulaLocal, 2)
If DarstF fxRefOnly Then 'Hier ggf diese DarstF untscheiden!
fmlAdrEnd = InStrRev(fml, ")"): fmlAdrAnf = 0
Do: fmlAdrAnf = InStr(fmlAdrAnf + 1, fml, "(")
Loop Until Mid(fml, fmlAdrAnf - 1, 1) Like fktNEnd
fmlAdrBer = Mid(fml, fmlAdrAnf + 1, fmlAdrEnd - fmlAdrAnf - 1)
fmlKp = 2 * Abs(CBool(InStr(fmlAdrBer, ")"))) + _
CInt(CBool(InStr(fmlAdrBer, "(")))
Select Case CBool(fmlKp)
Case Is = True 'Hier ggf nach zusgehör ()Paaren suchen!
If Not IsEmpty(fmlAdr) Then fmlAdrV = "#NULL!"
Case Is = False
If fml Like fmlAdrLiVgl Then
isAdrLi = CBool(InStr(fml, ","))
If isAdrLi Then
fmlAdrBer = Split(fmlAdrBer, ",")
For Each fmlAdr In fmlAdrBer
GoSub ea
If isLokF Then
fmLok = Replace(fmLok, fmlAdr, fmlAdrV)
Else: fml = Replace(fml, fmlAdr, fmlAdrV)
End If
Next fmlAdr
If isLokF Then fml = fmLok
Else: fmlAdr = fmlAdrBer
ea: If IsError(Range(fmlAdr)) Then
fmlAdrV = Array("#REF!", "#BEZUG!")(Abs(isLokF))
ElseIf BerWalsMxKonst Then
If InStr(fmlAdr, "!") = 0 Then
Set bezSh = hptSh
fmlAdrV = bezSh.Range(fmlAdr).Value2
Else: fmlAdrV = Range(fmlAdr).Value2
End If
With WorksheetFunction
fmlAdrV = .Transpose(fmlAdrV)
If IsError(UBound(fmlAdrV, 2)) Then isSpVek = True
If Not isSpVek Then
fmlAdrV = .Transpose(fmlAdrV)
If IsError(UBound(fmlAdrV, 2)) Then Else GoTo ew
End If
fmlTmpV = "": fmlTmpV = Join(fmlAdrV, Switch(isSpVek, _
";", isLokF, st, True, Chr(0)))
If fmlTmpV "" Then
If Not isLokF Then fmlTmpV = _
Replace(Replace(fmlTmpV, dt, "."), Chr(0), ",")
fmlAdrV = "{" & fmlTmpV & "}"
Else: GoTo ew
End If
If Not isLokF And _
IsError(Evaluate("=" & fmlAdrV)) Then GoTo ew
End With
Else
ew: Set bezSh = hptSh: fmlAdrV = Empty
If CBool(InStr(fmlAdr, "!")) Then
fmlAdr = Split(fmlAdr, "!")
Set bezSh = Sheets(fmlAdr(0)): fmlAdr = fmlAdr(1)
End If
isAdrBer = CBool(InStr(fmlAdr, ":"))
If isAdrBer Then
For Each zBez In bezSh.Range(fmlAdr)
GoSub et
fmlAdrV = fmlAdrV & IIf(isLokF, ";", ",") & fmlTmpV
Next zBez
fmlAdrV = Mid(fmlAdrV, 2)
Else: Set zBez = bezSh.Range(fmlAdr)
et: If BerWalsText Then
fmlTmpV = zBez.Text
Else: fmlTmpV = zBez.Value
If IsNumeric(fmlTmpV) Then
If Not isLokF And CBool(InStr(fmlTmpV, dt)) Then _
fmlTmpV = Replace(fmlTmpV, dt, ".")
End If
End If
If CBool(InStr(Trim(fmlTmpV), " ")) Or _
Not IsNumeric(fmlTmpV) Then
If Not isLokF And InStr(Trim(fmlTmpV), " ") = 0 And _
IsNumeric(Replace(fmlTmpV, ".", "")) Then
Else: fmlTmpV = """" & fmlTmpV & """"
End If
End If
If isAdrBer Then Return Else fmlAdrV = fmlTmpV
End If
End If
If isAdrLi Then Return
If isLokF Then
fmLok = Replace(fmLok, fmlAdr, fmlAdrV)
Else: fml = Replace(fml, fmlAdr, fmlAdrV)
End If
End If
ElseIf fml Like fmlAdrEzVgl Then
fmlAdr = fmlAdrBer
If IsError(Range(fmlAdr)) Then
fmlAdrV = Array("#REF!", "#BEZUG!")(Abs(isLokF))
Else
If InStr(fmlAdr, "!") = 0 Then
Set bezSh = hptSh
Set zBez = bezSh.Range(fmlAdr)
Else: Set zBez = Range(fmlAdr)
End If
If BerWalsText Then
fmlAdrV = zBez.Text
Else: fmlAdrV = zBez.Value
If IsNumeric(fmlAdrV) Then
If Not isLokF And CBool(InStr(fmlAdrV, dt)) Then _
fmlAdrV = Replace(fmlAdrV, dt, ".")
End If
End If
If CBool(InStr(Trim(fmlAdrV), " ")) Or _
Not IsNumeric(fmlAdrV) Then
If Not isLokF And InStr(Trim(fmlAdrV), " ") = 0 And _
IsNumeric(Replace(fmlAdrV, ".", "")) Then
Else: fmlAdrV = """" & fmlAdrV & """"
End If
End If
End If
End If
If isLokF Then
fmLok = Replace(fmLok, fmlAdr, fmlAdrV)
Else: fml = Replace(fml, fmlAdr, fmlAdrV)
End If
End Select
End If
End If
If isLokF Then FormHabit = fmLok Else FormHabit = fml
If Not isOhneErg Then
If BerWalsText Then
fmlTmpV = bez.Text
ElseIf Not isLokF And IsNumeric(bez) Then
fmlTmpV = Replace(bez, dt, ".")
Else: fmlTmpV = CStr(bez)
End If
If IsError(FormHabit) Or DarstF = fxRefOnly Then _
Else FormHabit = FormHabit & " = " & fmlTmpV
End If
If isMxBez Then Return
End If
ex: Err.Number = 0: Set ac = Nothing: Set berBez = Nothing: Set Bezug = Nothing
Set zBez = Nothing: Set bezSh = Nothing: Set hptSh = Nothing
End Function
Option Explicit steht hoffentl schon am Anfang deines allgemeinen Moduls; als nächstes folgt dann die Enumerationsprozedur (kannst du alles auf eine Zeile bringen, falls es Probleme mit der 2.Zeile gibt). Die von solchen Prozeduren eingestellten Werte sind quasi Globalvariablen, die auch nur in einem allgemeinen Modul eines VBA-Projekts vorhanden sein dürfen, — die „vergisst” Xl schon mal, wenn die PgmModule editiert wdn. Dann am besten die ganze Prozedur ausschneiden und wieder einfügen, dann sollten die Werte wieder da sein. Anderenfalls müsste Xl neu gestartet wdn. Im Normalbetrieb sollte das aber nicht passieren. Die Fktsproz FormHabit kannst du dann irgendwo in das/ein allgemeine/s Modul (kein Klassenmodul wie bspw die Ereignisprozz!) speichern.
Hoffe nur, dass keine wesentl Fehler mehr enthalten sind! Anderenfalls noch mal melden!
Viel Erfolg + schöDrAdWE, Luc :-?