VBA运行时错误1004：长公式写入单元格失败问题求助

编写了VBA过程UpdateFormula_LostRevenuesfromTerminationsinYTD2024，执行targetCell.Formula = targetFormula语句时触发Run-time error 1004（应用程序定义或对象定义错误）。短公式可正常运行，更换为当前长动态公式后报错，调整目标单元格定位逻辑无效，需要实现将动态公式正确写入目标单元格的功能。

原代码如下：

Sub UpdateFormula_LostRevenuesfromTerminationsinYTD2024()

Dim ws As Worksheet
Dim startMonth1 As String, endMonth1 As String
Dim startMonth2 As String, endMonth2 As String
Dim startCol1 As Long, endCol1 As Long
Dim startCol2 As Long, endCol2 As Long
Dim cell As Range
Dim targetFormula As String
Dim firstCol As Long
Dim lastCol As Long
Dim targetCell As Range

Set ws = ThisWorkbook.Sheets("Formula (Do Not Use)") ' Adjust the sheet name as needed

startMonth1 = InputBox("Enter the start month for the first range (e.g., Jan-2023):")
endMonth1 = InputBox("Enter the end month for the first range (e.g., Apr-2023):")
startMonth2 = InputBox("Enter the start month for the second range (e.g., Jan-2024):")
endMonth2 = InputBox("Enter the end month for the second range (e.g., Aug-2024):")

firstCol = ws.Cells(4, ws.Columns.Count).End(xlToLeft).Column
lastCol = ws.Cells(4, 1).End(xlToRight).Column

' Find columns with headers matching user input within green cells
For Each cell In ws.Range(ws.Cells(4, firstCol), ws.Cells(4, lastCol)) ' Adjust range to cover all header cells
    If cell.Interior.Color = RGB(169, 208, 142) Then ' Only look in green cells
        If cell.Value = startMonth1 Then startCol1 = cell.Column
        If cell.Value = endMonth1 Then endCol1 = cell.Column
        If cell.Value = startMonth2 Then startCol2 = cell.Column
        If cell.Value = endMonth2 Then endCol2 = cell.Column
    End If
Next cell

If startCol1 = 0 Or endCol1 = 0 Or startCol2 = 0 Or endCol2 = 0 Then
    MsgBox "One or more of the specified months were not found in the green cells."
    Exit Sub
End If

' Convert column numbers to column letters
Dim startColLetter1 As String, endColLetter1 As String
Dim startColLetter2 As String, endColLetter2 As String
startColLetter1 = ColumnLetter(startCol1)
endColLetter1 = ColumnLetter(endCol1)
startColLetter2 = ColumnLetter(startCol2)
endColLetter2 = ColumnLetter(endCol2)

targetFormula = "=IF(OR(ISNUMBER(CJ5), CJ5=""N/A"", ISNUMBER(CK5), CK5=""N/A"")," & _
                "IF(OR(AND(CJ5<>""N/A"", IFERROR((DATE(YEAR(CJ5), MONTH(CJ5), DAY(CJ5)) > DATE(2023,12,31)), FALSE))," & _
                "AND(CK5<>""N/A"", IFERROR((DATE(YEAR(CK5), MONTH(CK5), DAY(CK5)) > DATE(2023,12,31)), FALSE)))," & _
                "IFERROR(IF(FG5<>""""", """"", -SUM(" & startColLetter1 & "5:" & endColLetter1 & "5) + SUM(" & startColLetter2 & "5:" & endColLetter2 & "5)), """""),  """"), """"""")"

Set targetCell = Nothing
For Each cell In ws.UsedRange
    If cell.Value = "Lost Revenues from Terminations in YTD2024*" Then
        Set targetCell = cell.Offset(1, 0) ' Set target to the cell directly below
        Exit For
    End If
Next cell

If targetCell Is Nothing Then
    MsgBox "The cell with 'Lost Revenues from Terminations in YTD2024*' was not found."
    Exit Sub
End If

targetCell.Formula = targetFormula

End Sub

问题原因 #

1. HTML转义字符错误：公式中使用了<>（HTML的小于大于转义符），但Excel公式需要的是<>运算符，导致公式语法无效。
2. 引号转义错误：公式末尾的引号拼接错误，导致生成的公式引号不匹配，触发语法错误。
3. 日期处理冗余：DATE(YEAR(CJ5), MONTH(CJ5), DAY(CJ5))可直接简化为CJ5，若CJ5是日期格式，直接比较即可。

修正方案 #

1. 将所有<>替换为<>，>替换为>；
2. 修正引号的转义逻辑，确保生成的公式引号配对正确；
3. 简化冗余的日期处理代码；
4. 添加公式长度检查，避免超出Excel的公式字符限制（Excel 2007及以上支持最大8192字符）。

修正后的代码：

Sub UpdateFormula_LostRevenuesfromTerminationsinYTD2024()

Dim ws As Worksheet
Dim startMonth1 As String, endMonth1 As String
Dim startMonth2 As String, endMonth2 As String
Dim startCol1 As Long, endCol1 As Long
Dim startCol2 As Long, endCol2 As Long
Dim cell As Range
Dim targetFormula As String
Dim firstCol As Long
Dim lastCol As Long
Dim targetCell As Range

Set ws = ThisWorkbook.Sheets("Formula (Do Not Use)") ' 按需修改工作表名称

startMonth1 = InputBox("输入第一个范围的起始月份（例如：Jan-2023）：")
endMonth1 = InputBox("输入第一个范围的结束月份（例如：Apr-2023）：")
startMonth2 = InputBox("输入第二个范围的起始月份（例如：Jan-2024）：")
endMonth2 = InputBox("输入第二个范围的结束月份（例如：Aug-2024）：")

firstCol = ws.Cells(4, ws.Columns.Count).End(xlToLeft).Column
lastCol = ws.Cells(4, 1).End(xlToRight).Column

' 在绿色单元格中查找匹配用户输入的列标题
For Each cell In ws.Range(ws.Cells(4, firstCol), ws.Cells(4, lastCol))
    If cell.Interior.Color = RGB(169, 208, 142) Then
        If cell.Value = startMonth1 Then startCol1 = cell.Column
        If cell.Value = endMonth1 Then endCol1 = cell.Column
        If cell.Value = startMonth2 Then startCol2 = cell.Column
        If cell.Value = endMonth2 Then endCol2 = cell.Column
    End If
Next cell

If startCol1 = 0 Or endCol1 = 0 Or startCol2 = 0 Or endCol2 = 0 Then
    MsgBox "指定的一个或多个月份未在绿色单元格中找到。"
    Exit Sub
End If

' 将列号转换为列字母
Dim startColLetter1 As String, endColLetter1 As String
Dim startColLetter2 As String, endColLetter2 As String
startColLetter1 = ColumnLetter(startCol1)
endColLetter1 = ColumnLetter(endCol1)
startColLetter2 = ColumnLetter(startCol2)
endColLetter2 = ColumnLetter(endCol2)

' 修正后的公式拼接：替换转义字符、修正引号、简化日期判断
targetFormula = "=IF(OR(ISNUMBER(CJ5), CJ5=""N/A"", ISNUMBER(CK5), CK5=""N/A"")," & _
                "IF(OR(AND(CJ5<>""N/A"", IFERROR(CJ5 > DATE(2023,12,31), FALSE))," & _
                "AND(CK5<>""N/A"", IFERROR(CK5 > DATE(2023,12,31), FALSE)))," & _
                "IFERROR(IF(FG5<>"""", """", -SUM(" & startColLetter1 & "5:" & endColLetter1 & "5) + SUM(" & startColLetter2 & "5:" & endColLetter2 & "5)), """") , """") , """")"

' 检查公式长度
If Len(targetFormula) > 8192 Then
    MsgBox "公式长度超出Excel限制，请简化公式。"
    Exit Sub
End If

Set targetCell = Nothing
For Each cell In ws.UsedRange
    If cell.Value = "Lost Revenues from Terminations in YTD2024*" Then
        Set targetCell = cell.Offset(1, 0) ' 目标单元格为标题下方一行
        Exit For
    End If
Next cell

If targetCell Is Nothing Then
    MsgBox "未找到包含'Lost Revenues from Terminations in YTD2024*'的单元格。"
    Exit Sub
End If

targetCell.Formula = targetFormula

End Sub

关键修改点说明 #

• 替换了<>和>为Excel公式支持的<>和>；
• 修正了末尾的引号拼接，确保生成的公式引号完全配对；
• 将DATE(YEAR(CJ5), MONTH(CJ5), DAY(CJ5))简化为CJ5，减少冗余计算；
• 添加了公式长度检查，避免超出Excel的字符限制。

内容的提问来源于stack exchange，提问作者eggtofu