VBA Coding not working properly

chevenowner

New Member
Joined
Sep 10, 2014
Messages
18
Dear All.

I am trying to make Multiple selection from drop down appear in same cell.

I am try to do it at two different columns in same spreadsheet
it doesnt seem to work

One drop down with multiple selection work perfectly and appear in same cell

The other one is slightly diff code but doesnt run I have tried all sorts of things

Please see attached spreadsheet. let me know if you can work out the solution
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Please post your VBA code.

Many Thanks for ur email

HTML:
Private Sub Worksheet_Change(ByVal Target As Range)
   sub1_Change Target
   sub2_Change Target
End Sub

Private Sub sub1_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lCode As Long
Dim wsList As Worksheet
Dim rngList As Range
Dim rngListID As Range
If Target.Count > 1 Then GoTo exitHandler
Set wsList = ActiveSheet
Set rngList = wsList.Range("external")
Set rngListID = wsList.Range("externalID")
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 = 8 Then
    If oldVal = "" Then
      'do nothing
         lCode = rngListID.Range("A1") _
            .Offset(Application. _
                WorksheetFunction _
                .Match(Target.Value, _
                rngList, 0) - 1, 0)
         Target.Offset(0, 1).Value = lCode
   
   Else
      If newVal = "" Then
        'do nothing
         Target.Offset(0, 1).ClearContents
      Else
         lCode = rngListID.Range("A1") _
            .Offset(Application. _
                WorksheetFunction _
                .Match(Target.Value, _
                rngList, 0) - 1, 0)
         Target.Value = oldVal _
           & ", " & newVal
         Target.Offset(0, 1).Value = Target.Offset(0, 1).Value _
           & ", " & lCode
      End If
    End If
  End If
End If
exitHandler:
  Application.EnableEvents = True
End Sub
Private Sub sub2_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
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 = 11 Then
    If oldVal = "" Then
      'do nothing
      Else
      If newVal = "" Then
      'do nothing
      Else
      Target.Value = oldVal _
        & ", " & newVal
      End If
    End If
  End If
End If
exitHandler:
  Application.EnableEvents = True
End Sub

Sub 1 WORKS FINE
But sub 2 doesnt

I know the code is correct, as it works individually on a differnt tab, just not together with sub 1
 
Last edited:
Upvote 0
I don't really understand why you need two very similar procedures. Can't you put all the code in the Worksheet_Change procedure, removing the duplicated parts? You'll need to have 2 oldVal and newVal variables, with different names of course.
 
Upvote 0
I don't really understand why you need two very similar procedures. Can't you put all the code in the Worksheet_Change procedure, removing the duplicated parts? You'll need to have 2 oldVal and newVal variables, with different names of course.

Thanks

These are two seperate codes tahts y

First sub gives me room used and in next column room used price

so etc
you can select 1room, 2room etc in next column a price will appear , associated with the rooms

but for 2nd sub all i want is audience type
and no relative codes to appear in same cell multiple selective
 
Upvote 0
Try (untested):

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    Dim lCode As Long
    Dim wsList As Worksheet
    Dim rngList As Range
    Dim rngListID As Range
    If Target.Count > 1 Then GoTo exitHandler
    Set wsList = ActiveSheet
    Set rngList = wsList.Range("external")
    Set rngListID = wsList.Range("externalID")
    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 = 8 Then
            If oldVal = "" Then
'               do nothing
                lCode = rngListID.Range("A1") _
                    .Offset(Application. _
                    WorksheetFunction _
                    .Match(Target.Value, _
                    rngList, 0) - 1, 0)
                Target.Offset(0, 1).Value = lCode
            Else
                If newVal = "" Then
'                   do nothing
                    Target.Offset(0, 1).ClearContents
                Else
                    lCode = rngListID.Range("A1") _
                        .Offset(Application. _
                        WorksheetFunction _
                        .Match(Target.Value, _
                        rngList, 0) - 1, 0)
                    Target.Value = oldVal _
                        & ", " & newVal
                    Target.Offset(0, 1).Value = Target.Offset(0, 1).Value _
                        & ", " & lCode
                End If
            End If
        ElseIf Target.Column = 11 Then
            If oldVal = "" Then
'               do nothing
            Else
                If newVal = "" Then
'                   do nothing
                Else
                    Target.Value = oldVal _
                        & ", " & newVal
                End If
            End If
        End If
    End If
exitHandler:
    Application.EnableEvents = True
End Sub
 
Upvote 0
Try (untested):

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    Dim lCode As Long
    Dim wsList As Worksheet
    Dim rngList As Range
    Dim rngListID As Range
    If Target.Count > 1 Then GoTo exitHandler
    Set wsList = ActiveSheet
    Set rngList = wsList.Range("external")
    Set rngListID = wsList.Range("externalID")
    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 = 8 Then
            If oldVal = "" Then
'               do nothing
                lCode = rngListID.Range("A1") _
                    .Offset(Application. _
                    WorksheetFunction _
                    .Match(Target.Value, _
                    rngList, 0) - 1, 0)
                Target.Offset(0, 1).Value = lCode
            Else
                If newVal = "" Then
'                   do nothing
                    Target.Offset(0, 1).ClearContents
                Else
                    lCode = rngListID.Range("A1") _
                        .Offset(Application. _
                        WorksheetFunction _
                        .Match(Target.Value, _
                        rngList, 0) - 1, 0)
                    Target.Value = oldVal _
                        & ", " & newVal
                    Target.Offset(0, 1).Value = Target.Offset(0, 1).Value _
                        & ", " & lCode
                End If
            End If
        ElseIf Target.Column = 11 Then
            If oldVal = "" Then
'               do nothing
            Else
                If newVal = "" Then
'                   do nothing
                Else
                    Target.Value = oldVal _
                        & ", " & newVal
                End If
            End If
        End If
    End If
exitHandler:
    Application.EnableEvents = True
End Sub

Sir it worked :D
OMG AMAZING !

You are a star !!!!
I can not thank you enough !!!
I just can not

There is one slight issue, which its still showing me...can i tell u ?
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,034
Members
448,543
Latest member
MartinLarkin

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