VBA for Listbox to current selected cell

G

GeneBF

New Member
Joined
Jun 28, 2022
Messages
35
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code: 
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
 
Sort by date Sort by votes
DanteAmor said:
Im glad to help you. Thanks for the feedback.
Click to expand...
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)
1657171090687.png
 
Upvote 0

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
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!
,
1657177716889.png
 
Upvote 0
GeneBF said:
as you can see it includes a <BLANK> choice, im wondering why is it not appearing
Click to expand...
GeneBF said:
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
Click to expand...
I made adjustments for those issues:
VBA Code: 
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
 
Last edited:
Upvote 0
Solution
GeneBF said:
it works on me, what seems the problem on your end bro?
Click to expand...

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.
 

Attachments

  • stocks.png
    stocks.png
    125.7 KB · Views: 9
Upvote 0
DanteAmor said:
I made adjustments for those issues:
VBA Code: 
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
Click to expand...
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Searching using TextBox and ListBox
Replies
1
Views
279
campbell1093
C
I
  • Question Question
Select Listbox value to be then taken to customer on worksheet
Replies
1
Views
138
ipbr21054
I
I
  • Solved
Advice to use the same code but from top of sheet down the page
Replies
2
Views
68
ipbr21054
I
I
  • Solved
Also have the row number shown in Listbox on userform advice
Replies
7
Views
146
NoSparks
N
I
  • Solved
Listbox to show dd/mm/yyyy & not mm/dd/yyyy
2
Replies
13
Views
145
Alex Blakenburg
A

Forum statistics

Threads
1,224,813
Messages
6,181,117
Members
453,021
Latest member
Justyna P

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