合并多个宏（工作表更改）

Question

我正在尝试合并以下宏：

1. 在下拉列表中进行多选
2. 自适应合并单元格大小
3. 在表单中隐藏/显示行

这些宏可以单独使用，但是它们应该添加到同一个特定的工作表中，我无法弄清楚如何将它们合并。任何帮助都将不胜感激。谢谢！

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Oldvalue As String
Dim Newvalue As String

On Error GoTo Exitsub
If Target.Address = "$F$8" Or Target.Address = "$F$9" Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
    GoTo Exitsub
    Else: If Target.Value = "" Then GoTo Exitsub Else
        Application.EnableEvents = False
        Newvalue = Target.Value
        Application.Undo
        Oldvalue = Target.Value
        If Oldvalue = "" Then
            Target.Value = Newvalue
        Else
            Target.Value = Oldvalue & ", " & Newvalue
        End If
    End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewRwHt As Single
    Dim cWdth As Single, MrgeWdth As Single
    Dim c As Range, cc As Range
    Dim ma As Range
    With Target
        If .MergeCells And .WrapText Then
            Set c = Target.Cells(1, 1)
            cWdth = c.ColumnWidth
            Set ma = c.MergeArea
            For Each cc In ma.Cells
                MrgeWdth = MrgeWdth + cc.ColumnWidth
            Next
            Application.ScreenUpdating = False
            ma.MergeCells = False
            c.ColumnWidth = MrgeWdth
            c.entirerow.AutoFit
            NewRwHt = c.RowHeight
            c.ColumnWidth = cWdth
            ma.MergeCells = True
            ma.RowHeight = NewRwHt
            cWdth = 0: MrgeWdth = 0
            Application.ScreenUpdating = True
        End If
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Where As Range, Area As Range, This As Range, Here As Range
  Dim First As Boolean
  Dim i As Long
 
  Application.ScreenUpdating = False
  Set Where = FindAll(Me.Columns("H"), "Section")
  For Each Area In Where.Cells
    If Area.MergeCells Then Set Area = Area.MergeArea
    First = True
    For Each This In Area.Cells
      Set Here = Intersect(Range("A:G"), This.EntireRow)
      i = WorksheetFunction.CountBlank(Here)
      This.EntireRow.Hidden = (i = Here.Columns.Count) And Not First
      First = i <> Here.Columns.Count
    Next
  Next
  Application.ScreenUpdating = True
End Sub

- Anca

---

将它们全部重命名，然后创建一个新的worksheet_change，调用每一个。 - Warcupine

谢谢@Warcupine！我已经尝试过了，但还是不起作用。私有子运行() 调用多重选择 调用自适应合并 调用隐藏/取消隐藏 结束子 - Anca

最后一个是关于什么的？代码中没有包含“Target”？它应该在什么时候运行？ - VBasic2008

@VBasic2008 最后一个（HideUnhide）每次前一个不为空时都会显示一个新行。即在表单中，我可以添加最多10行详细信息。默认情况下，只显示第一行（空白）。如果我填写了该行，则会显示一个新的空白行，依此类推，直到填满所有10行（如有需要）。如果我单独运行宏，它本身是有效的。 - Anca

@VBasic2008 谢谢！它有效了！ - Anca

Answer 1

合并工作表更改事件的代码

代码：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    MultipleSelection Target
    AutofitMerge Target
    HideUnhide Me
End Sub

Private Sub MultipleSelection(ByVal Target As Range)

Dim Oldvalue As String
Dim Newvalue As String

On Error GoTo Exitsub
If Target.Address = "$F$8" Or Target.Address = "$F$9" Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
    GoTo Exitsub
    Else: If Target.Value = "" Then GoTo Exitsub Else
        Application.EnableEvents = False
        Newvalue = Target.Value
        Application.Undo
        Oldvalue = Target.Value
        If Oldvalue = "" Then
            Target.Value = Newvalue
        Else
            Target.Value = Oldvalue & ", " & Newvalue
        End If
    End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

Private Sub AutofitMerge(ByVal Target As Range)
    Dim NewRwHt As Single
    Dim cWdth As Single, MrgeWdth As Single
    Dim c As Range, cc As Range
    Dim ma As Range
    With Target
        If .MergeCells And .WrapText Then
            Set c = Target.Cells(1, 1)
            cWdth = c.ColumnWidth
            Set ma = c.MergeArea
            For Each cc In ma.Cells
                MrgeWdth = MrgeWdth + cc.ColumnWidth
            Next
            Application.ScreenUpdating = False
            ma.MergeCells = False
            c.ColumnWidth = MrgeWdth
            c.EntireRow.AutoFit
            NewRwHt = c.RowHeight
            c.ColumnWidth = cWdth
            ma.MergeCells = True
            ma.RowHeight = NewRwHt
            cWdth = 0: MrgeWdth = 0
            Application.ScreenUpdating = True
        End If
    End With
End Sub

Private Sub HideUnhide(ByVal ws As Worksheet)
  Dim Where As Range, Area As Range, This As Range, Here As Range
  Dim First As Boolean
  Dim i As Long
 
  Application.ScreenUpdating = False
  Set Where = FindAll(ws.Columns("H"), "Section")
  For Each Area In Where.Cells
    If Area.MergeCells Then Set Area = Area.MergeArea
    First = True
    For Each This In Area.Cells
      Set Here = Intersect(Range("A:G"), This.EntireRow)
      i = WorksheetFunction.CountBlank(Here)
      This.EntireRow.Hidden = (i = Here.Columns.Count) And Not First
      First = i <> Here.Columns.Count
    Next
  Next
  Application.ScreenUpdating = True
End Sub

- VBasic2008