none
Combining two macros RRS feed

  • Question

  • I got two macros which i need to work at the same time

    These are auto activated macro.

    The first one allow me to get multiple selection from a data validation list

    The second one allow me to see the data validation input message in a text box

    Both work individually but, I don't know why, when i add the second one, the first one stops working but the second one works pretty well.

    I did not create these macro neither am I an excel master.

    Please let me know.

    Private Sub Worksheet_Change
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    Dim lUsed As Long
    If Target.Count > 1 Then GoTo exitHandler
    
    On Error Resume Next
    Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitHandler
    
    If rngDV Is Nothing Then GoTo exitHandler
    
    If Intersect(Target, rngDV) Is Nothing Then
       'do nothing
    Else
      Application.EnableEvents = False
      newVal = Target.Value
      Application.Undo
      oldVal = Target.Value
      Target.Value = newVal
      If Target.Column = 9 Then
        If oldVal = "" Then
          'do nothing
          Else
          If newVal = "" Then
          'do nothing
          Else
            lUsed = InStr(1, oldVal, newVal)
            If lUsed > 0 Then
                If Right(oldVal, Len(newVal)) = newVal Then
                    Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
                Else
                    Target.Value = Replace(oldVal, newVal & ", ", "")
                End If
            Else
                Target.Value = oldVal _
                  & ", " & newVal
            End If
            
          End If
        End If
      End If
    End If
    exitHandler:
      Application.EnableEvents = True
    End Sub
    
    
    
    
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim strTitle As String
    Dim strMsg As String
    Dim strMsgAdd As String
    Dim sTemp As Shape
    Dim lDVType As Long
    Dim lRowMsg As Long
    Dim ws As Worksheet
        Application.EnableEvents = False
    Set ws = ActiveSheet
    Set sTemp = ws.Shapes("TextBox 1")
    On Error Resume Next
    lDVType = 0
    lDVType = Target.Validation.Type
    On Error GoTo errHandler
      If lDVType = 0 Then
       sTemp.TextFrame.Characters.Text = ""
       sTemp.Visible = msoFalse
      Else
        If Target.Validation.InputTitle <> "" Or _
              Target.Validation.InputMessage <> "" Then
          strTitle = Target.Validation.InputTitle & Chr(10)
          On Error Resume Next
          lRowMsg = 0
          lRowMsg = Application.WorksheetFunction.Match(Target.Validation.InputTitle, Sheets("MsgText").Columns(1), 0)
          If lRowMsg > 0 Then
             strMsgAdd = Sheets("MsgText").Cells(lRowMsg, 2).Value
          End If
          On Error GoTo errHandler
          strMsg = Target.Validation.InputMessage
          With sTemp.TextFrame
            .Characters.Text = strTitle & strMsg & Chr(10) & strMsgAdd
            .Characters.Font.Bold = False
            .Characters(1, Len(strTitle)).Font.Bold = True
          End With
          sTemp.Visible = msoTrue
        Else
          sTemp.TextFrame.Characters.Text = ""
          sTemp.Visible = msoFalse
        End If
      End If
    errHandler:
      Application.EnableEvents = True
    End Sub

    Tuesday, January 13, 2015 3:50 PM

Answers

  • What was occurring was the SelectionChange event was being called every time you clicked the validation dropdown even though a real selection change had not taken place. The fix is to use a public variable to record the selected cell range and compare that to the target and if selection has not changed then exit the selection change event.

    The public variable needs to be at the top of the module before any subs. Although I refer to it as as Public, it is only available to subs within the module where it is declared. If you wanted to use this variable in other modules (ie. make it Public throughout the project) then it needs to be placed at the top of a standard module and specifically declared as Public like the following.

    Public rngSelected As Range

    Replace your code with the following.

    Option Explicit

    Dim rngSelected as Range    'Must be at top of module before any other subs

    ' Developed by Contextures Inc.
    ' www.contextures.com
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    Dim lUsed As Long
    ActiveSheet.Unprotect Password:="SMFF"
    If Target.Count > 1 Then GoTo exitHandler

    On Error Resume Next
    Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitHandler

    If rngDV Is Nothing Then GoTo exitHandler

    If Intersect(Target, rngDV) Is Nothing Then
       'do nothing
    Else
      Application.EnableEvents = False
      newVal = Target.Value
      Application.Undo
      oldVal = Target.Value
      Target.Value = newVal
      If Target.Column = 9 Then
        If oldVal = "" Then
          'do nothing
          Else
          If newVal = "" Then
          'do nothing
          Else
            lUsed = InStr(1, oldVal, newVal)
            If lUsed > 0 Then
                If Right(oldVal, Len(newVal)) = newVal Then
                    Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
                Else
                    Target.Value = Replace(oldVal, newVal & ", ", "")
                End If
            Else
                Target.Value = oldVal _
                  & ", " & newVal
            End If
           
          End If
        End If
      End If
    End If
    exitHandler:
      Application.EnableEvents = True
    End Sub

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Not rngSelected Is Nothing Then  'If Nothing then no previous selection since opening workbook
        'Next line if Not nothing then is something. Therefore selection change has NOT taken place
        If Not Intersect(rngSelected, Target) Is Nothing Then Exit Sub
    End If

    Set rngSelected = Target

    Dim strTitle As String
    Dim strMsg As String
    Dim strMsgAdd As String
    Dim sTemp As Shape
    Dim lDVType As Long
    Dim lRowMsg As Long
    Dim ws As Worksheet
        Application.EnableEvents = False
    Set ws = ActiveSheet
    Set sTemp = ws.Shapes("TextBox 1")
    On Error Resume Next
    lDVType = 0
    lDVType = Target.Validation.Type
      If lDVType = 0 Then
       sTemp.TextFrame.Characters.Text = ""
      Else
        If Target.Validation.InputTitle <> "" Or _
              Target.Validation.InputMessage <> "" Then
          strTitle = Target.Validation.InputTitle & Chr(10)
          On Error Resume Next
          lRowMsg = 0
          lRowMsg = Application.WorksheetFunction.Match(Target.Validation.InputTitle, Sheets("MsgText").Columns(1), 0)
          If lRowMsg > 0 Then
             strMsgAdd = Sheets("MsgText").Cells(lRowMsg, 2).Value
          End If
          On Error GoTo errHandler
          strMsg = Target.Validation.InputMessage
          With sTemp.TextFrame
            .Characters.Text = strTitle & strMsg & Chr(10) & strMsgAdd
            .Characters.Font.Bold = False
            .Characters(1, Len(strTitle)).Font.Bold = True
          End With
          sTemp.Visible = msoTrue
        Else
          sTemp.TextFrame.Characters.Text = ""
        End If
      End If
    errHandler:
      Application.EnableEvents = True
    End Sub


    Regards, OssieMac

    Thursday, January 15, 2015 12:57 AM

All replies

  • I have watched this thread all day thinking that someone will be able to understand what you are trying to achieve but it appears that everyone else is in the dark like me.

    Your first example of code is missing the arguments for the sub. Should be like the following:

    Private Sub Worksheet_Change(ByVal Target As Range)

    Can you post an example workbook with an explanation on the worksheet of what you want to occur. Simply make a copy of the worksheet into another workbook and if it contains sensitive data then replace with other data.

    Guidelines to post a workbook on OneDrive

    1. Zip your workbooks. I prefer that you do not just save to OneDrive. (To Zip a file, in Windows Explorer  Right click on the selected file and select Send to -> Compressed (zipped) folder.)
    2. Go to this link.  https://onedrive.live.com
    3. Use the same login Id and Password that you use for this forum.
    4. Select Upload in the blue bar across the top and browse to the zipped folder to be uploaded and select Open (or just double click). (Be patient and give it time to display the file after initially seeing the popup indicating it is done.)
    5. Right click the file on OneDrive and select Share.
    6. Do NOT fill in the form; "Select Get a Link" on the left side.
    7. Click the button "Create a Link"
    8. Click in the box where the link is created and it will highlight.
    9. Copy the link and paste into your reply on this forum.

    Regards, OssieMac

    Wednesday, January 14, 2015 8:54 AM
  • Here you go.

    Thanks a lot for your time

    http://1drv.ms/1xZmHGu

    Wednesday, January 14, 2015 4:09 PM
  • What was occurring was the SelectionChange event was being called every time you clicked the validation dropdown even though a real selection change had not taken place. The fix is to use a public variable to record the selected cell range and compare that to the target and if selection has not changed then exit the selection change event.

    The public variable needs to be at the top of the module before any subs. Although I refer to it as as Public, it is only available to subs within the module where it is declared. If you wanted to use this variable in other modules (ie. make it Public throughout the project) then it needs to be placed at the top of a standard module and specifically declared as Public like the following.

    Public rngSelected As Range

    Replace your code with the following.

    Option Explicit

    Dim rngSelected as Range    'Must be at top of module before any other subs

    ' Developed by Contextures Inc.
    ' www.contextures.com
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    Dim lUsed As Long
    ActiveSheet.Unprotect Password:="SMFF"
    If Target.Count > 1 Then GoTo exitHandler

    On Error Resume Next
    Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitHandler

    If rngDV Is Nothing Then GoTo exitHandler

    If Intersect(Target, rngDV) Is Nothing Then
       'do nothing
    Else
      Application.EnableEvents = False
      newVal = Target.Value
      Application.Undo
      oldVal = Target.Value
      Target.Value = newVal
      If Target.Column = 9 Then
        If oldVal = "" Then
          'do nothing
          Else
          If newVal = "" Then
          'do nothing
          Else
            lUsed = InStr(1, oldVal, newVal)
            If lUsed > 0 Then
                If Right(oldVal, Len(newVal)) = newVal Then
                    Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
                Else
                    Target.Value = Replace(oldVal, newVal & ", ", "")
                End If
            Else
                Target.Value = oldVal _
                  & ", " & newVal
            End If
           
          End If
        End If
      End If
    End If
    exitHandler:
      Application.EnableEvents = True
    End Sub

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Not rngSelected Is Nothing Then  'If Nothing then no previous selection since opening workbook
        'Next line if Not nothing then is something. Therefore selection change has NOT taken place
        If Not Intersect(rngSelected, Target) Is Nothing Then Exit Sub
    End If

    Set rngSelected = Target

    Dim strTitle As String
    Dim strMsg As String
    Dim strMsgAdd As String
    Dim sTemp As Shape
    Dim lDVType As Long
    Dim lRowMsg As Long
    Dim ws As Worksheet
        Application.EnableEvents = False
    Set ws = ActiveSheet
    Set sTemp = ws.Shapes("TextBox 1")
    On Error Resume Next
    lDVType = 0
    lDVType = Target.Validation.Type
      If lDVType = 0 Then
       sTemp.TextFrame.Characters.Text = ""
      Else
        If Target.Validation.InputTitle <> "" Or _
              Target.Validation.InputMessage <> "" Then
          strTitle = Target.Validation.InputTitle & Chr(10)
          On Error Resume Next
          lRowMsg = 0
          lRowMsg = Application.WorksheetFunction.Match(Target.Validation.InputTitle, Sheets("MsgText").Columns(1), 0)
          If lRowMsg > 0 Then
             strMsgAdd = Sheets("MsgText").Cells(lRowMsg, 2).Value
          End If
          On Error GoTo errHandler
          strMsg = Target.Validation.InputMessage
          With sTemp.TextFrame
            .Characters.Text = strTitle & strMsg & Chr(10) & strMsgAdd
            .Characters.Font.Bold = False
            .Characters(1, Len(strTitle)).Font.Bold = True
          End With
          sTemp.Visible = msoTrue
        Else
          sTemp.TextFrame.Characters.Text = ""
        End If
      End If
    errHandler:
      Application.EnableEvents = True
    End Sub


    Regards, OssieMac

    Thursday, January 15, 2015 12:57 AM