Combine two Worksheet_Change in one Makro - VBA

N

Nadine1988

Board Regular
Joined
Jun 12, 2023
Messages
62
Office Version
  1. 365
Platform
  1. Windows
Hello,

I'm really new to the VBA world and I'm currently trying to create a form which can be filled out. I got pretty far already but now I'm stuck. the problem is that I don't know how to combine two makro's under one Worksheet_Change.
So i do have this existing makro which is working perfectly fine:

'Mehrfachselektion mit Löschfunktion

Option Explicit
Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = vbCrLf
Dim DelimiterCount As Integer
Dim TargetType As Integer
Dim i As Integer
Dim arr() As String

If Destination.Count > 1 Then Exit Sub
On Error Resume Next

Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError

If rngDropdown Is Nothing Then GoTo exitError
If Destination.Address <> "$C$41" And Destination.Address <> "$D$41" And Destination.Address <> "$C$51" And Destination.Address <> "$D$51" Then GoTo exitError

TargetType = 0
TargetType = Destination.Validation.Type
If TargetType = 3 Then ' is validation type is "list"
Application.ScreenUpdating = False
Application.EnableEvents = False
newValue = Destination.Value
Application.Undo
oldValue = Destination.Value
Destination.Value = newValue
If oldValue <> "" Then
If newValue <> "" Then
If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
oldValue = Replace(oldValue, DelimiterType, "")
oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
Destination.Value = oldValue
ElseIf InStr(1, oldValue, DelimiterType & newValue) Then
arr = Split(oldValue, DelimiterType)
If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
Destination.Value = oldValue & DelimiterType & newValue
Else:
Destination.Value = ""
For i = 0 To UBound(arr)
If arr(i) <> newValue Then
Destination.Value = Destination.Value & arr(i) & DelimiterType
End If
Next i
Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
End If
ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
oldValue = Replace(oldValue, newValue, "")
Destination.Value = oldValue
Else
Destination.Value = oldValue & DelimiterType & newValue
End If
Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
Destination.Value = Replace(Destination.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
If Destination.Value <> "" Then
If Right(Destination.Value, 2) = DelimiterType Then ' remove delimiter at the end
Destination.Value = Left(Destination.Value, Len(Destination.Value) - 2)
End If
End If
If InStr(1, Destination.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
Destination.Value = Replace(Destination.Value, DelimiterType, "", 1, 1)
End If
If InStr(1, Destination.Value, Replace(DelimiterType, " ", "")) = 1 Then
Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
End If
DelimiterCount = 0
For i = 1 To Len(Destination.Value)
If InStr(i, Destination.Value, Replace(DelimiterType, " ", "")) Then
DelimiterCount = DelimiterCount + 1
End If
Next i
If DelimiterCount = 1 Then ' remove delimiter if last character
Destination.Value = Replace(Destination.Value, DelimiterType, "")
Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "")
End If
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End If

exitError:
Application.EnableEvents = True


End Sub


What I now need is to add a makro which does the following: When "No" is choosen in the dorpdown in cell D43, rows 45 - 55 needs to be hidden. If "Yes" is choosen in the dropdown the rows needs to be shown. I don't know where to add the makro in above code... Looking forward to your help :)

Thanks
Nadin
 
Sort by date Sort by votes
it's a dropdown so yes, it only has these two options but nothings happens when I choose one of the two options.
 

Attachments

  • demopool.JPG
    demopool.JPG
    175.6 KB · Views: 6
Upvote 0

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
"The position is correct if you want the rows to be hidden before your original code executes." - hmm... okay, they should actually both be executed at the same time.. it's a form which needs to be filled in so people probably won't do every row at a time... is this even possible?
 
Upvote 0
Put a MsgBox in to check the value of D43.

Check for a space either before or after the 'Yes' or 'No' or maybe even before and after.

VBA Code: 
        Cells.EntireRow.Hidden = False
        
         MsgBox ">" & Range("D43").Value & "<"
 
Upvote 0
Nadine1988 said:
"The position is correct if you want the rows to be hidden before your original code executes." - hmm... okay, they should actually both be executed at the same time.. it's a form which needs to be filled in so people probably won't do every row at a time... is this even possible?
Click to expand...

Sure the checks that you are making are only valid for some cells.

If that is the case then only run the code when those particular cells have been changed.

It appears that you are only checking cells where the validation type is list.

Have you no control on what goes in the list?
 
Upvote 0
Herakles said:
Sure the checks that you are making are only valid for some cells.

If that is the case then only run the code when those particular cells have been changed.

It appears that you are only checking cells where the validation type is list.

Have you no control on what goes in the list?
Click to expand...
Yes, it's all more or less with drop down but I can't tell in wich order the fields will be filled out.
 
Upvote 0
Herakles said:
Put a MsgBox in to check the value of D43.

Check for a space either before or after the 'Yes' or 'No' or maybe even before and after.

VBA Code: 
        Cells.EntireRow.Hidden = False
       
         MsgBox ">" & Range("D43").Value & "<"
Click to expand...
tried that too... still not working ... i will try again, but thanks for your help!
 
Upvote 0
Nadine1988 said:
Yes, it's all more or less with drop down but I can't tell in wich order the fields will be filled out.
Click to expand...

Can you explain what you are trying to do when a selection from a validation list is made?
 
Upvote 0
hold on - it's working 🥳 don't know how but it's working!

can you now tell me how I can an other one with the same code but different cells - i tried to simply copy it but it's only working for D43 but not for D55



VBA Code: 
'Mehrfachselektion mit Löschfunktion
Option Explicit

Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = vbCrLf
Dim DelimiterCount As Integer
Dim TargetType As Integer
Dim i As Integer
Dim arr() As String

        Cells.EntireRow.Hidden = False
        
        If Range("D43").Value = "No" Then
            Rows("44:52").EntireRow.Hidden = True
        ElseIf Range("D43").Value = "Yes" Then
            Rows("44:52").EntireRow.Hidden = False
        
        End If
        
        
        If Range("D55").Value = "No" Then
            Rows("57:65").EntireRow.Hidden = True
        ElseIf Range("D55").Value = "Yes" Then
            Rows("57:65").EntireRow.Hidden = False
        End If
                 
If Destination.Count > 1 Then Exit Sub
On Error Resume Next
 
Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError
 
If rngDropdown Is Nothing Then GoTo exitError
If Destination.Address <> "$C$41" And Destination.Address <> "$D$41" And Destination.Address <> "$C$51" And Destination.Address <> "$D$51" Then GoTo exitError

TargetType = 0
    TargetType = Destination.Validation.Type
    If TargetType = 3 Then  ' is validation type is "list"
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        newValue = Destination.Value
        Application.Undo
        oldValue = Destination.Value
        Destination.Value = newValue
        If oldValue <> "" Then
            If newValue <> "" Then
                If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
                    oldValue = Replace(oldValue, DelimiterType, "")
                    oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
                    Destination.Value = oldValue
                ElseIf InStr(1, oldValue, DelimiterType & newValue) Then
                    arr = Split(oldValue, DelimiterType)
                If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
                    Destination.Value = oldValue & DelimiterType & newValue
                        Else:
                    Destination.Value = ""
                    For i = 0 To UBound(arr)
                    If arr(i) <> newValue Then
                        Destination.Value = Destination.Value & arr(i) & DelimiterType
                    End If
                    Next i
                Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
                End If
                ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
                    oldValue = Replace(oldValue, newValue, "")
                    Destination.Value = oldValue
                Else
                    Destination.Value = oldValue & DelimiterType & newValue
                End If
                Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
                Destination.Value = Replace(Destination.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
                If Destination.Value <> "" Then
                    If Right(Destination.Value, 2) = DelimiterType Then  ' remove delimiter at the end
                        Destination.Value = Left(Destination.Value, Len(Destination.Value) - 2)
                    End If
                End If
                If InStr(1, Destination.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
                    Destination.Value = Replace(Destination.Value, DelimiterType, "", 1, 1)
                End If
                If InStr(1, Destination.Value, Replace(DelimiterType, " ", "")) = 1 Then
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
                End If
                DelimiterCount = 0
                For i = 1 To Len(Destination.Value)
                    If InStr(i, Destination.Value, Replace(DelimiterType, " ", "")) Then
                        DelimiterCount = DelimiterCount + 1
                    End If
                Next i
                If DelimiterCount = 1 Then ' remove delimiter if last character
                    Destination.Value = Replace(Destination.Value, DelimiterType, "")
                    Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "")
                End If
            End If
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
 
exitError:
  Application.EnableEvents = True


End Sub

'Command Button

Private Sub CommandButton1_Click()
Dim xOutlookObj As Object
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next
    
    If IsEmpty(Range("A7")) Then
    MsgBox "Enter date"
    GoTo ends
    
    Else
    If IsEmpty(Range("D7")) Then
    MsgBox "Enter Vizrt sales peson"
    GoTo ends
        
    Else
    If IsEmpty(Range("C9")) Then
    MsgBox "Enter the start date of your rental"
    GoTo ends
  
    Else
    If IsEmpty(Range("C11")) Then
    MsgBox "Enter the end date of your rental"
    GoTo ends
    
End If
End If
End If
End If
    
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Please add any special requirements here. For FOC rentals - please attach Vanessa's approval to your email." & vbNewLine & vbNewLine & _
              "" & vbNewLine & _
              ""
                  On Error Resume Next
    With xOutMail
        .To = "non@vizrt.com"
        .CC = ""
        .BCC = ""
        .Subject = "Enter the Email Subject Here"
        .Body = xMailBody
        .Attachments.Add ActiveWorkbook.FullName
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
    
ends:
      
End Sub
 
Upvote 0
Are you trying to hide other rows based upon the value in particular cells a you did with D43?

If not then what are you trying to do?

What was the original code doing?
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Combining 3 Worksheet_Change events
Replies
4
Views
302
Kevo
K
R
  • Question
How to combine the functions of having the ability to select multiple items from a drop down list and hide columns based on values of said list?
Replies
0
Views
222
rgree05
R
O
  • Solved
Combining two VBA Codes Change (ByVal Target) and (ByVal Destination)
2
Replies
10
Views
950
OscarMDMBA
O
J
  • Solved
Combining VBA
Replies
3
Views
414
JackReacher85
J
J
  • Locked
  • Question
Vlookup from multiselect data validation list
Replies
2
Views
753
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,111
Messages
6,123,159
Members
449,098
Latest member
Doanvanhieu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top