CODEWITHSUNDEEP
excelvba
Ali
Ali

Reputation: 1

Combining Private Sub Worksheet_change excel

I hope you're doing. I am struggling with combining two Private Sub Worksheet_change(byval Target As Range) on excel. I would really appreciate if you help me combine these two codes.

I am kinda new to excel vba world so your input would be a big help for me

Code 1

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xPTable As PivotTable
    Dim xPFile As PivotField
    Dim xStr As String
    On Error Resume Next
   
    If Intersect(Target, Range("B3:F3")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Sheet4").PivotTables("PivotTable3")
    Set xPFile = xPTable.PivotFields("Program2")
    xStr = Range("B3").Value
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True

    If Intersect(Target, Range("B3:F3")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xPTable = Worksheets("Sheet4").PivotTables("PivotTable3")
    Set xPFile = xPTable.PivotFields("ProgramType2")
    xStr = Range("C3").Value
    xPFile.ClearAllFilters
    xPFile.CurrentPage = xStr
    Application.ScreenUpdating = True

Code 2

    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = False
    On Error GoTo Exitsub
    If Target.Address = "$C$3" 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
            If InStr(1, Oldvalue, Newvalue) = 0 Then
                Target.Value = Oldvalue & ", " & Newvalue
            Else:
            Target.Value = Oldvalue
            End If
        End If
        End If
    End If
    Application.EnableEvents = True
Exitsub:
    Application.EnableEvents = True
End Sub

Upvotes: 0

Views: 324

Answers (1)

Tim Williams
Tim Williams

Reputation: 166306

Like this:

Private Sub Worksheet_Change(ByVal Target As Range)
    UpdatePivots Target
    MultiSelect Target
End Sub
    
Sub UpdatePivots(Target As Range)
    
    If Intersect(Target, Range("B3:F3")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    
    On Error Resume Next
   
    With Worksheets("Sheet4").PivotTables("PivotTable3")
        With .PivotFields("Program2")
            .ClearAllFilters
            .CurrentPage = Range("B3").Value
        End With
        With .PivotFields("ProgramType2")
            .ClearAllFilters
            .CurrentPage = Range("C3").Value
        End With
   End With
End Sub

Sub MultiSelect(Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
    
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Address(False, False) <> "C3" Then Exit Sub
    If Len(Target.Value) = 0 Then Exit Sub
    If Not HasValidationList(Target) Then Exit Sub
    
    On Error GoTo Exitsub
    Application.EnableEvents = False
    Newvalue = Target.Value
    Application.Undo
    Oldvalue = Target.Value
    If Oldvalue = "" Then
        Target.Value = Newvalue
    Else
        If InStr(1, Oldvalue, Newvalue) = 0 Then
            Target.Value = Oldvalue & ", " & Newvalue
        Else
            Target.Value = Oldvalue
        End If
    End If
Exitsub:
    Application.EnableEvents = True
End Sub

'does a ell have a validation list configured?
Function HasValidationList(c As Range) As Boolean
    Dim t As Long
    On Error Resume Next
    t = c.Validation.Type
    HasValidationList = (t = xlValidateList)
End Function

Upvotes: 0

Related Questions