.
, formarray- A1- ( "=" )
, "if()" . , , .
, , . , .
, , ( ). , , , .
Public Sub InsertFormulaArray(formula As String, targetCell As Range)
'Die Zeile der Zellenangabe für die Platzhalter
'Existiert in der Formel eine Zeilenangabe, die diesen Wert enthält, muss dieser Wert geändert werden.
Dim uniqueLine As String
uniqueLine = 1337
'Substituiert If-Funktionen, die kürzer sind als dieser Wert
'dieser Wert muss kleiner sein als die R1C1-Notation jeder If-Funktion innerhalb der Gesamtfunktion.
Dim lenghtTolerance As Integer
lenghtTolerance = 150
'Initialisiert Array, um die Ersetzungen zu protokollieren
Dim arrLenght As Integer
arrLenght = -1
Dim replaceArr() As String
'speichert der InputString für die Prüfung am Ende
Dim InputFormula As String
InputFormula = "=" & formula
'Suche die IF Befehle
Dim currentIF As Integer
Dim replaceChar As Integer
replaceChar = Asc("A")
Dim compression As Integer
'Sprungmarke, für eine mehrdimensionale kompression
RestartReplacement:
'inputLen benötige ich für die Entscheidung, ob eine weitere kompression notwendig ist
'(vergleich vorher nachher)
Dim inputLen As Integer
inputLen = Len(formula)
'findet den Anfang der ersten If-Funktion der Formel
currentIF = InStr(1, formula, "IF(")
'Findet das Ende der aktuellen If-Funktion
While Not currentIF = 0
'gibt die Tiefe der aktuellen If-Funktion an
Dim depth As Integer
depth = 0
'gibt die position der letzten Ziffer der aktuellen If-Funktion an. (0 - nicht gefunden)
Dim ifEnd As Integer
ifEnd = 0
'Setzt und initialisiert den Zähler
'(Position im String bei der Suche nach dem Ende der Funktion)
Dim i As Integer
i = currentIF
'Zu Debug-Zwecken habe ich mir die aktuelle Ziffer herausgezogen
Dim currentChar As String
'Schleife, bis das Ende der If-Funktion gefunden wurde - Fehler falls nicht
While ifEnd = 0
currentChar = Mid(formula, i, 1)
'Ermittelt die aktuelle tiefe
If currentChar = "(" Then
depth = depth + 1
End If
If currentChar = ")" Then
depth = depth - 1
'Setze ifEnd, wenn genausoviele Klammern geschlossen wie geöffnet wurden
If depth = 0 Then
ifEnd = i
End If
End If
'Zähler rauf
i = i + 1
'Gibt einen Fehler zurück, wenn "i" größer ist, als der String
If i > Len(formula) And ifEnd = 0 Then
MsgBox "Die eingegebene Formel ist keine gültige Englische Formel: " & """" & formula & """"
End
End If
Wend
'Gebe die ermittelte If-Funktion als String aus
Dim ifFunction As String
ifFunction = Mid(formula, currentIF, (ifEnd + 1 - (currentIF)))
'Ersetze die IF-Formel, wenn sie kürzer ist, als lenghtTolerance
If Len(ifFunction) < lenghtTolerance Then
'Schreibt den String in ein Array
arrLenght = arrLenght + 1
ReDim Preserve replaceArr(arrLenght)
replaceArr(arrLenght) = ifFunction
'Substituiere die If-Funktion in die Formel
formula = Replace(formula, ifFunction, Chr(replaceChar) & uniqueLine)
replaceChar = replaceChar + 1
'Wirft mich raus, wenn die Formel 26 mal substituiert wurde
If replaceChar > Asc("Z") Then
'Sorge dafür, dass ich beim nächsten Versuch aus dem While fliege
currentIF = Len(formula) - 1
'Sorge dafür, dass ich mich nicht mehr wiederhole -> compression = 0
inputLen = Len(formula)
End If
End If
'Sucht den Anfang der nächsten If-Funktion
currentIF = InStr(currentIF + 1, formula, "IF(")
Wend
'Ermittel, wie stark die Funktion durch diesen Vorgang komprimiert wurde
compression = inputLen - Len(formula)
'Überprüft, ob noch IF-Funktionen vorhanden sind
'Wiederholt die kompression, falls die letzte kompression nicht erfolglos war
If currentIF = 0 And InStr(1, formula, "IF(") > 0 And compression > 0 Then
GoTo RestartReplacement
End If
'Schreibt die komprimierte Formel in die gewünschte Zelle
Application.ScreenUpdating = False
targetCell.FormulaArray = ("=" & formula)
'Setzt replaceChar eins zurück, um den letzten ersetzenden Buchstaben anzugeben
replaceChar = replaceChar - 1
'Ersetzt rückwärts alle "replacements"
For i = arrLenght To 0 Step -1
'Dim replacementStr As String
'replacementStr = Chr(replaceChar) & uniqueLine
targetCell.Replace What:=(Chr(replaceChar) & uniqueLine), replacement:=replaceArr(i), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
replaceChar = replaceChar - 1
Next i
Application.ScreenUpdating = True
'Überprüfe das Ergebnis
Dim result As String
result = targetCell.FormulaArray
If result = InputFormula Then
'Einsetzen erfolgreich!
Else
MsgBox "Beim einsetzen einer Formel in die Zelle """ & targetCell.Address & """ ist ein Fehler aufgetreten!" & vbCrLf & "Die aktuelle Aktion wird abgebrochen!"
End
End If
End Sub
, ( if- ). , vba . FormulaArray Replace-command , , . uniqueLine 1337, .
150, , 150 . 255 R1C1-, A1-, , , . , .
,
B_Nut