Combining multiple macros (worksheet_change)

Anca Published at Dev

Anca

I am trying to combine the following macros:

Multiple selection in a drop down list
Autofit merged cells
Hide/unhide rows in a form

Macros work individually but they should all be added in the same specific worksheet and I cannot figure out how to combine them. Any help is appreciated. Thanks!

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

VBasic2008

Combine Worksheet Change Event Codes

The Code

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

Collected from the Internet

Please contact [email protected] to delete if infringement.