根据单元格值合并单元格的脚本

Question

我很难找到一种根据单元格的值合并单元格的方法。这就是我需要的：

我在 D 列和 E 列中有两个依赖的下拉菜单。当在单元格 E12 中选择值“DD9900”时，我想要一个将 E12 与 E13 合并以及 D12 与 D13 合并的脚本。

澄清一下，当 E12 中的值为 DD9900 时，应发生以下合并：

-单元格 E12 与 E13 合并

-单元格 D12 与 D13 合并

示例

ChatGPT 帮助我为单个单元格 (E12) 创建了一个解决方案，但我需要一个代码，将相同的逻辑应用于从 E12 到 E52 的整个范围。

有人可以帮我吗？

谢谢！

这是ChatGPT生成的代码（仅适用于一个单元格）

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Check if the changed cell is E12
    If Not Intersect(Target, Me.Range("E12")) Is Nothing Then
        Application.EnableEvents = False
        ' Clear any previous merges in D12:D13 and E12:E13
        If Me.Range("D12:D13").MergeCells Then Me.Range("D12:D13").Unmerge
        If Me.Range("E12:E13").MergeCells Then Me.Range("E12:E13").Unmerge

        ' Check the value in E12
        If Me.Range("E12").Value = "DD9900" Then
            ' Merge D12:D13 and E12:E13
            Me.Range("D12:D13").Merge
            Me.Range("E12:E13").Merge
        End If
        Application.EnableEvents = True
    End If
End Sub

Answer 1

尝试以下代码。

Target

是被修改的单元格。当单元格不在 E12:E52 范围内时，程序将退出。
我还通过检查是否仅更改了一个单元格来简化了代码 - 如果没有更改（例如通过剪切和粘贴），例程将退出而不执行任何操作。

现在我定义了两个范围变量：

rColD

代表已修改单元格左侧的单元格（

Offset(0, -1)

，即 D 列）加上其下方的下一个单元格 (

Resize(2, 1)

)。

rColE

类似，只是我们不需要

Offset

函数，因为我们已经位于正确的列（E 列）中。

现在我们检查单元格是否获得了魔法值

DD9900

。
如果是并且范围尚未合并，请合并它们。
如果否并且范围已合并，则取消合并。

Private Sub Worksheet_Change(ByVal Target As Range)
    Const theMagicValue = "DD9900"
    
    If Target.Count > 1 Then Exit Sub
    If Intersect(Target, Range("E12:E52")) Is Nothing Then Exit Sub
    
    Dim rColD As Range, rColE As Range
    Set rColD = Target.Offset(0, -1).Resize(2, 1)
    Set rColE = Target.Resize(2, 1)
    
    If Target.Value = theMagicValue Then
        If Not rColD.MergeCells Then rColD.Merge
        If Not rColE.MergeCells Then rColE.Merge
    Else
        If rColD.MergeCells Then rColD.UnMerge
        If rColE.MergeCells Then rColE.UnMerge
    End If
End Sub

Answer 2

工作表更改：有条件合并单元格

Private Sub Worksheet_Change(ByVal Target As Range)
    
    ' Define constants.
    Const TARGET_RANGE_ADDRESS As String = "E12:E52"
    Const TARGET_STRING As String = "DD9900"
    Const OTHER_COLUMN As String = "D"
    Const MERGING_ROWS_COUNT As Long = 2
    Const AFTER_MERGE_ROW_OFFSET  As Long = 1
    Const AFTER_MERGE_COLUMN_OFFSET As Long = 0
    
    ' Restrict the code to a single changed cell.
    If Target.Cells.CountLarge > 1 Then Exit Sub
    
    ' Reference the target range.
    Dim trg As Range: Set trg = Me.Range(TARGET_RANGE_ADDRESS)
    
    ' Check if the changed cell ('Target')
    ' is not part of the target range ('trg').
    If Intersect(trg, Target) Is Nothing Then Exit Sub
    
    ' Reference the ranges, e.g. for 'E12' - 'E12:E13', 'D12:D13'
    Dim rg1 As Range: Set rg1 = Target.Resize(MERGING_ROWS_COUNT)
    Dim rg2 As Range: Set rg2 = rg1.EntireRow.Columns(OTHER_COLUMN)
    
    ' Implement an error-handling routine to ensure events get enabled
    ' even after an error occurs.
    On Error GoTo ClearError
    
    ' Disable events to prevent retriggering this code when writing
    ' to this worksheet. Remember to always reeenable them later.
    Application.EnableEvents = False
    
    ' Unmerge the cells and their merge areas.
    Dim cell As Range
    For Each cell In rg1.Cells
        If cell.MergeCells Then cell.MergeArea.UnMerge
    Next cell
    For Each cell In rg2.Cells
        If cell.MergeCells Then cell.MergeArea.UnMerge
    Next cell
    
    ' Merge the ranges conditionally.
    Application.DisplayAlerts = False ' prevent 'Merge Cells' alert
    If CStr(Target.Value) = TARGET_STRING Then ' A<>a
    'If StrComp(CStr(Target.Value), TARGET_STRING, vbTextCompare) = 0 Then ' A=a
        rg1.Merge
        Application.Goto rg1 _
            .Offset(AFTER_MERGE_ROW_OFFSET, AFTER_MERGE_COLUMN_OFFSET)
        rg2.Merge
    End If
    
ProcExit:
    On Error Resume Next ' prevent endless loop if error in continuation
        Application.DisplayAlerts = True
        Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub
ClearError: ' continue error-handling routine
    MsgBox "Run-time error [" & Err.Number & "]:" & vbLf & vbLf _
        & Err.Description, vbCritical
    Resume ProcExit
End Sub