excel - 组合多个宏 (worksheet_change)

Question

我正在尝试组合以下宏:

1. 在下拉列表中进行多项选择
2. 自动调整合并单元格
3. 隐藏/取消隐藏表单中的行

宏单独工作，但它们都应该添加到同一个特定工作表中，我不知道如何组合它们。任何帮助表示赞赏。谢谢!

1)

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

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