Help with on cell change

[mosslovell]

Hi All,

Ive been trying to sort this out,

I found this code that works when I click in the column D
But what I also want is if I click in column E a Different list is loaded.

This is the code that works

Option Explicit
Dim fillRng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBobj As OLEObject
Dim i As Long
Set LBobj = Me.OLEObjects("ListJobs")
'------------------------------
' Set LBobj = Me.OLEObjects("ListOutcome") This is the list I want to load if column E is entered
'-------------------------------
Set LBColors = LBobj.Object
If Not Intersect(Target, [D:D]) Is Nothing Then
Set fillRng = Target
With LBobj
.Left = fillRng.Left
.Top = fillRng.Top
.Width = fillRng.Width
.Visible = True
End With
Else
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRng.Value = "" Then
If .Selected(i) Then fillRng.Value = .List(i)
Else
If .Selected(i) Then fillRng.Value = _
fillRng.Value & "," & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
End If
End If

End Sub


Please Help

Moss

 

[onlyadrafter]

Hello,

haven't tested this, but running through it, it seems OK.

Option Explicit
Dim fillRng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBobj As OLEObject
Dim i As Long
    If Not Intersect(Target, [D:E]) Is Nothing Then
        If Not Intersect(Target, [D:D]) Is Nothing Then
            Set LBobj = Me.OLEObjects("ListJobs")
        End If
        If Not Intersect(Target, [E:E]) Is Nothing Then
            Set LBobj = Me.OLEObjects("ListOutcome")
        End If
        Set LBColors = LBobj.Object
        Set fillRng = Target
        With LBobj
            .Left = fillRng.Left
            .Top = fillRng.Top
            .Width = fillRng.Width
            .Visible = True
        End With
    Else
        LBobj.Visible = False
        If Not fillRng Is Nothing Then
            fillRng.ClearContents
            With LBColors
                If .ListCount <> 0 Then
                    For i = 0 To .ListCount - 1
                        If fillRng.Value = "" Then
                            If .Selected(i) Then fillRng.Value = .List(i)
                        Else
                        If .Selected(i) Then fillRng.Value = _
                            fillRng.Value & "," & .List(i)
                        End If
                    Next
                End If
                For i = 0 To .ListCount - 1
                    .Selected(i) = False
                 Next
            End With
            Set fillRng = Nothing
        End If
    End If
End Sub

Let me know if not working properly, may need a copy of the spreadsheet, if possible.

 

[mosslovell]

Thank you so much for your quick reply.

I have tried the cobe but get an error message saying Object variable or with block not set

How can I send you the spread sheet.

Moss