VBA for Listbox to current selected cell

[GeneBF]

Hi Ive been wondering, how to code a multi select Listbox that will pop-up when the cell is selected (like drop down list) and display the results in the same cell (separated by comma)
This is the closest one I've found in a site (https://eksi30.com/show-listbox-whe...=e431e80acf351d257fc0b53d0ca6b726#comment-476)
I need to rework this to reflect a Named (formula/ range), example: Zone1, and other problem with this is everytime i change my selection, the tick in the list is always cleared and never retained.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i, x, j As Long, Temp As Variant
If Not Intersect(Range("A:A"), Target) Is Nothing And Target.Count = 1 And Target.Address(False, False) <> "A1" Then
If ActiveCell.Row >= 1000 Then
ActiveWindow.ScrollRow = ActiveCell.Row - 999
End If
         Me.ListBox1.MultiSelect = fmMultiSelectMulti
      
Me.ListBox1.Clear
'Unique Records
For x = 2 To Sheets("List").Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Sheets("List").Range("A2:A" & x), Sheets("List").Cells(x, 1)) = 1 Then
ListBox1.AddItem Sheets("List").Cells(x, 1).Value
End If
Next

With ListBox1
    For i = 0 To .ListCount - 2
            For j = i + 1 To .ListCount - 1
                If UCase(.List(i)) > UCase(.List(j)) Then
                    Temp = .List(j)
                   .List(j) = .List(i)
                    .List(i) = Temp
                End If
            Next j
        Next i
    End With
        
      For i = 0 To Me.ListBox1.ListCount - 1
      If Target <> Empty And Me.ListBox1.List(i, 0) = Target.Text Then
      Me.ListBox1.Selected(i) = True
      End If
      Next i
        
        Me.ListBox1.Top = Target.Top
        Me.ListBox1.Left = Target.Left + Target.Width
        Me.ListBox1.Visible = True
            Else
        Me.ListBox1.Visible = False
      
    End If
i = Empty
End Sub

Private Sub ListBox1_Change()
Dim gir As String
    For i = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(i) = True Then
            gir = gir & " ," & Me.ListBox1.List(i)
        End If
    Next i
    ActiveCell.Value = Trim(gir)
End Sub

 

[GeneBF]

Im glad to help you. Thanks for the feedback.

Hi, i have another question , although this is more of a convenience this is actually my Range, as you can see it includes a <BLANK> choice, im wondering why is it not appearing. (I can just put a formula to replace x with blank on my output cell but im just wondering for future reference why is it not appearing)

 

[GeneBF]

also on another minor inconvenience again the listbox wont hide itself if I select a single cell first then proceed to shift select adjacents cells. Cheers mate thanks!
,

 

[DanteAmor]

as you can see it includes a <BLANK> choice, im wondering why is it not appearing

also on another minor inconvenience again the listbox wont hide itself if I select a single cell first then proceed to shift select adjacents cells

I made adjustments for those issues:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim i As Long, j As Long, x As Long
  Dim Temp As Variant, itm As Variant
  Dim rng As Range, c As Range
 
  Me.ListBox1.Visible = False

  If Not Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then
    If Target.CountLarge > 1 Then Exit Sub
 
    Set rng = Sheets("List").Range("ListName")
    With Me.ListBox1
      .MultiSelect = fmMultiSelectMulti
      .ListStyle = fmListStyleOption
      .Clear
      .Top = Target.Top
      .Left = Target.Left + Target.Width
      .Visible = True
      'Unique Records
      For x = 1 To rng.Cells.Rows.Count
        If Evaluate("=SUM(--(" & rng.Cells(1).Resize(x).Address(external:=True) & "=" & rng.Cells(x).Address(external:=True) & "))") = 1 Then
          .AddItem rng.Cells(x).Value
        End If
      Next
      'Sort Records
      For i = 0 To .ListCount - 2
        For j = i + 1 To .ListCount - 1
          If UCase(.List(i)) > UCase(.List(j)) Then
            Temp = .List(j)
            .List(j) = .List(i)
            .List(i) = Temp
          End If
        Next j
      Next i
      'Mark Records
      If Target.Value <> "" Then
        For Each itm In Split(Target.Value, ", ")
          For i = 0 To .ListCount - 1
            If .List(i) = itm Then
              .Selected(i) = True
            End If
          Next
        Next
      End If
    End With
  End If
End Sub

Private Sub ListBox1_Change()
  Dim gir As String
  Dim i As Long
  gir = ""
  For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then
      gir = gir & Me.ListBox1.List(i) & ", "
    End If
  Next i
  If gir <> "" Then
    ActiveCell.Value = Left(gir, Len(gir) - 2)
  Else
    ActiveCell.Value = ""
  End If
End Sub

 

[Hukam]

it works on me, what seems the problem on your end bro?

first sheet "PRICE RECEIVED BY DDE" have name and quotes, which automatically updates every sec with DDE server. (refer attached picture)
second sheet "CHANGES" have quotes track records with time.. ( i am looking or VBA solution for this part which helps to Copy Past each change in row format, new changes automatically dropdown to next row).
i am looking for VBA code which can easily update quotes form first sheet to second sheet, and keep this track record on second sheet might be limits upto 20,000 rows per asset.
sorry i haven't explain it before, any solution please.
thanks.

 

[GeneBF]

I made adjustments for those issues:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim i As Long, j As Long, x As Long
  Dim Temp As Variant, itm As Variant
  Dim rng As Range, c As Range
 
  Me.ListBox1.Visible = False

  If Not Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then
    If Target.CountLarge > 1 Then Exit Sub
 
    Set rng = Sheets("List").Range("ListName")
    With Me.ListBox1
      .MultiSelect = fmMultiSelectMulti
      .ListStyle = fmListStyleOption
      .Clear
      .Top = Target.Top
      .Left = Target.Left + Target.Width
      .Visible = True
      'Unique Records
      For x = 1 To rng.Cells.Rows.Count
        If Evaluate("=SUM(--(" & rng.Cells(1).Resize(x).Address(external:=True) & "=" & rng.Cells(x).Address(external:=True) & "))") = 1 Then
          .AddItem rng.Cells(x).Value
        End If
      Next
      'Sort Records
      For i = 0 To .ListCount - 2
        For j = i + 1 To .ListCount - 1
          If UCase(.List(i)) > UCase(.List(j)) Then
            Temp = .List(j)
            .List(j) = .List(i)
            .List(i) = Temp
          End If
        Next j
      Next i
      'Mark Records
      If Target.Value <> "" Then
        For Each itm In Split(Target.Value, ", ")
          For i = 0 To .ListCount - 1
            If .List(i) = itm Then
              .Selected(i) = True
            End If
          Next
        Next
      End If
    End With
  End If
End Sub

Private Sub ListBox1_Change()
  Dim gir As String
  Dim i As Long
  gir = ""
  For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then
      gir = gir & Me.ListBox1.List(i) & ", "
    End If
  Next i
  If gir <> "" Then
    ActiveCell.Value = Left(gir, Len(gir) - 2)
  Else
    ActiveCell.Value = ""
  End If
End Sub

once again really great help you saved me hours of work with it, hope i can be as efficient as you in vba code soon! cheers thanks again

 

[DanteAmor]

Again with pleasure. Thanks for the feedback