我需要插入几个非常长且复杂的公式。
我编写了一段代码，可以在英文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和excel有意义。集成的FormulaArray和Replace命令将无法处理无意义的公式，这也是我进行替换的主要原因。在这种情况下，uniqueLine为1337，但如果需要，您可以更改它。
长度容差设置为150，这意味着只有短于150个字符的公式部分才会被替换。对于R1C1表示法的公式，限制为255，即使它以A1表示法给出，所以处理后的代码比给定的公式更长，您需要一些余地。您不需要那么多余地，但对我来说有效。
祝您拥有愉快的一天，
B_Nut
