我很难找到一种根据单元格的值合并单元格的方法。这就是我需要的:
我在 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
尝试以下代码。
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
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