替换IF公式实现相邻单元格联动默认值的VBA代码需求

The original code uses formulas in F8:F17, which prevents manual edits since any change would overwrite the formula. To meet your requirement—where F cells default to 1 when their corresponding C cell has content (and remain editable), and clear when C is empty—we’ll use a combination of initial value setup and a Worksheet_Change event to handle dynamic updates.

Here’s the revised macro:

Sub Print_New()
    ' Print_New Macro
    ActiveSheet.Unprotect
    ActiveSheet.Range("$B$7:$G$24").AutoFilter Field:=1, Criteria1:="<>"
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    ActiveSheet.Range("$B$7:$G$24").AutoFilter Field:=1
    ActiveSheet.Protect
    
    ' Copy the sheet and get reference to the new sheet
    Dim newSheet As Worksheet
    Set newSheet = Sheets("Bill (1)").Copy(Before:=Sheets(5))
    
    With newSheet
        .Unprotect
        ' Clear specified ranges
        .Range("C8:C17,D20,E20:F20").ClearContents
        ' Set G20 formula
        .Range("G20").FormulaR1C1 = "=IF(RC[-2]="""","""",5%)"
        
        ' Set initial values for F8:F17 based on C8:C17
        Dim cell As Range
        For Each cell In .Range("C8:C17")
            If cell.Value <> "" Then
                .Range("F" & cell.Row).Value = 1
            Else
                .Range("F" & cell.Row).ClearContents
            End If
        Next cell
        
        .Protect
    End With
    
    ' Add Worksheet_Change event to the new sheet to handle future edits
    AddChangeEventToSheet newSheet
    
    ActiveWorkbook.Save
End Sub

Sub AddChangeEventToSheet(targetSheet As Worksheet)
    Dim vbProj As VBIDE.VBProject
    Dim vbComp As VBIDE.VBComponent
    Dim codeModule As VBIDE.CodeModule
    Dim codeText As String
    
    Set vbProj = ThisWorkbook.VBProject
    Set vbComp = vbProj.VBComponents(targetSheet.CodeName)
    Set codeModule = vbComp.CodeModule
    
    ' Clear existing change event if present
    On Error Resume Next
    codeModule.DeleteLines _
        codeModule.ProcStartLine("Worksheet_Change", vbext_pk_Proc), _
        codeModule.ProcCountLines("Worksheet_Change", vbext_pk_Proc)
    On Error GoTo 0
    
    ' Define the event code
    codeText = "Private Sub Worksheet_Change(ByVal Target As Range)" & vbCrLf & _
               "    Dim watchRange As Range" & vbCrLf & _
               "    Set watchRange = Me.Range(""C8:C17"")" & vbCrLf & _
               "" & vbCrLf & _
               "    ' Check if the changed cell is in our target range" & vbCrLf & _
               "    If Not Intersect(Target, watchRange) Is Nothing Then" & vbCrLf & _
               "        Dim changedCell As Range" & vbCrLf & _
               "        For Each changedCell In Intersect(Target, watchRange)" & vbCrLf & _
               "            Me.Unprotect" & vbCrLf & _
               "            If changedCell.Value <> """" Then" & vbCrLf & _
               "                ' Only set to 1 if F cell is empty (preserve manual edits)" & vbCrLf & _
               "                If Me.Range(""F"" & changedCell.Row).Value = """" Then" & vbCrLf & _
               "                    Me.Range(""F"" & changedCell.Row).Value = 1" & vbCrLf & _
               "                End If" & vbCrLf & _
               "            Else" & vbCrLf & _
               "                Me.Range(""F"" & changedCell.Row).ClearContents" & vbCrLf & _
               "            End If" & vbCrLf & _
               "            Me.Protect" & vbCrLf & _
               "        Next changedCell" & vbCrLf & _
               "    End If" & vbCrLf & _
               "End Sub"
    
    ' Insert the code at the end of the module
    codeModule.InsertLines codeModule.CountOfLines + 1, codeText
End Sub

Key Changes Explained: #

• Initial F Cell Setup: When creating the new sheet, we loop through C8:C17 and set F cells to 1 if C has content (as values, not formulas), so they’re editable right away.
• Worksheet_Change Event: This event triggers whenever a cell in C8:C17 is modified:
  • If you enter content into a C cell, the corresponding F cell is set to 1 only if it’s empty (so any manual edits you make to F are preserved).
  • If you clear a C cell, the F cell is cleared automatically.
  • The sheet is temporarily unprotected during the update to avoid permission issues.

Important Note: #

To use the AddChangeEventToSheet subroutine, you need to enable access to the VBA project object model:

1. Go to File > Options > Trust Center > Trust Center Settings > Macro Settings.
2. Check Trust access to the VBA project object model.
3. Click OK and restart Excel if needed.

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