Formel als Text mit Werten ausgeben

  • Excel

    Formel als Text mit Werten ausgeben

    Hallo,

    kann ich eine Formel mit deren zugehörigen Werten ausgeben?

    Als Beispiel:

    Quellcode

    1. A1: 1
    2. A2: 2
    3. A3: 3
    5. B1: =A1*A2*A3 (ergibt natürlich 6)
    7. jetzt möchte ich aber, dass diese Formel als Text mit zugehörigen Werten ausgegeben wird. Das Ergebnis müsste also so aussehen:
    8. B1: 1*2*3 (anstatt A1*A2*A3, das wäre ja über FORMELTEXT einfach zu machen)


    Geht sowas?
    Per VERKETTEN ist das natürlich machbar, aber immer recht viel Aufwand bei langen Formeln.

    Gruß


    Antwort:

    Visual Basic-Quellcode

    1. 'by sandy666 (http://www.excelforum.com/showthread.php?t=1128613&p=4326610&viewfull=1#post4326610)
    2. Const debugMode As Boolean = False
    4. Public Function LiteralFormula(ByVal rng As Excel.Range, _
    5. Optional extraParens As Boolean = False) _
    6. As String
    7. Const maxAddressLength As Integer = 12
    8. Dim inQuotes As Boolean
    10. Dim parseString As String, tempString As String
    11. Dim addressLength As Long, parsePosition As Long
    12. Dim rangeLength As Long
    14. Dim cursor As Long
    15. Dim returnValue As String
    16. Dim formulaString As String
    18. If (rng.HasFormula) Then
    19. formulaString = VBA.Right$(rng.Formula, _
    20. VBA.Len(rng.Formula) - 1)
    21. Else
    22. Exit Function
    23. End If
    25. If debugMode Then
    26. Debug.Print rng.Address & " has a formula: " & rng.Formula
    27. End If
    29. If Not hasReference(rng) Then
    30. 'no references in range, exiting
    31. LiteralFormula = formulaString
    32. If debugMode Then
    33. Debug.Print "Returning " & formulaString
    34. End If
    35. Exit Function
    36. End If
    38. For cursor = 1 To VBA.Len(formulaString)
    39. parseString = VBA.Mid$(formulaString, cursor, maxAddressLength)
    41. If debugMode Then
    42. Debug.Print "parsing string: " & parseString
    43. ' Stop
    44. End If
    46. If (VBA.Left$(parseString, 1) = VBA.Chr(34)) Then
    47. inQuotes = Not inQuotes
    48. End If
    50. If Not inQuotes Then
    51. addressLength = 0
    52. For parsePosition = 2 To maxAddressLength
    53. If isAddress(VBA.Left$(parseString, parsePosition)) Then
    54. addressLength = parsePosition
    55. Debug.Print "Parse progress: " & VBA.Left$(parseString, parsePosition), _
    56. "Address length: " & addressLength
    57. ' Stop
    58. Else
    59. Exit For
    60. End If
    61. Next parsePosition
    63. If addressLength > 0 Then
    64. returnValue = returnValue & rng.Parent.Range(VBA.Left$(parseString, addressLength)).Value
    65. cursor = cursor + addressLength - 1
    66. Else
    67. returnValue = returnValue & VBA.Left$(parseString, 1)
    68. End If
    69. Else
    70. returnValue = returnValue & VBA.Left$(parseString, 1)
    71. End If
    72. Next cursor
    73. LiteralFormula = returnValue
    74. End Function
    76. Private Function hasReference(ByVal rng As Range) _
    77. As Boolean
    78. If Not rng.HasFormula Then Exit Function
    80. If isAddress(rng.Formula, False) Then
    81. hasReference = True
    82. End If
    83. End Function
    85. Private Function isAddress(strTest As String, _
    86. Optional wholestring As Boolean = True) _
    87. As Boolean
    88. Dim re As Object
    89. Dim strPattern As String
    91. Set re = CreateObject("VBScript.RegExp")
    93. If (wholestring) Then strPattern = "^"
    94. strPattern = strPattern & _
    95. "[\$]{0,1}[A-Z]{1,3}[\$]{0,1}[1-9][0-9]{0,6}"
    96. If (wholestring) Then strPattern = strPattern & "$"
    98. re.Pattern = strPattern
    99. re.IgnoreCase = True
    101. isAddress = re.test(strTest)
    102. End Function

    Für ein Mindestmaß an Rechtschreibung, Interpunktion und Majuskeln!

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „bla“ ()

Facebook
Telefonspende