VBA for Listbox to current selected cell

G

GeneBF

New Member
Joined
Jun 28, 2022
Messages
34
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
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
Hi and welcome to MrExcel!

I corrected some details in the code. Try the following and comment if you need anything else.
You need to have your data in column A on the "List" sheet.

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 sh As Worksheet
  
  If Not Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then
    If Target.CountLarge > 1 Then Exit Sub
    
    Set sh = Sheets("List")
    With Me.ListBox1
      .MultiSelect = fmMultiSelectMulti
      .ListStyle = fmListStyleOption
      .Clear
      .Top = Target.Top
      .Left = Target.Left + Target.Width
      .Visible = True
      
      'Unique Records
      For x = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row
        If WorksheetFunction.CountIf(sh.Range("A2:A" & x), sh.Cells(x, 1)) = 1 Then
          .AddItem sh.Cells(x, 1).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
  Else
    Me.ListBox1.Visible = False
  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
 
Upvote 0
DanteAmor said:
Hi and welcome to MrExcel!

I corrected some details in the code. Try the following and comment if you need anything else.
You need to have your data in column A on the "List" sheet.

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 sh As Worksheet
 
  If Not Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then
    If Target.CountLarge > 1 Then Exit Sub
   
    Set sh = Sheets("List")
    With Me.ListBox1
      .MultiSelect = fmMultiSelectMulti
      .ListStyle = fmListStyleOption
      .Clear
      .Top = Target.Top
      .Left = Target.Left + Target.Width
      .Visible = True
     
      'Unique Records
      For x = 2 To sh.Cells(Rows.Count, 1).End(xlUp).Row
        If WorksheetFunction.CountIf(sh.Range("A2:A" & x), sh.Cells(x, 1)) = 1 Then
          .AddItem sh.Cells(x, 1).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
  Else
    Me.ListBox1.Visible = False
  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...
Replying too late sorry, Im wondering how i will recreate this code's LIST using a named range instead of putting it in 'LIST' sheet
also thanks for making the code way cleaner i appreciate it!
 
Upvote 0
GeneBF said:
Im wondering how i will recreate this code's LIST using a named range
Click to expand...
Try this, just change the sheet name and named range, in the data marked in blue:

Rich (BB 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
  
  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 WorksheetFunction.CountIf(rng.Cells(1).Resize(x), rng.Cells(x).Value) = 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
  Else
    Me.ListBox1.Visible = False
  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
 
Upvote 0
Hi Ive been wondering if life is little easier, stock prices are updating every second, can we keep auto tracking record of their changes in another sheet.. like attached format.
thanks
 

Attachments

  • stocks.png
    stocks.png
    125.7 KB · Views: 8
Upvote 0
DanteAmor said:
Try this, just change the sheet name and named range, in the data marked in blue:

Rich (BB 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
 
  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 WorksheetFunction.CountIf(rng.Cells(1).Resize(x), rng.Cells(x).Value) = 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
  Else
    Me.ListBox1.Visible = False
  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...
really appreciate this, works better and looks cleaner now too. Thanks!
 
Upvote 0
Im glad to help you. Thanks for the feedback.
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
VBA user form search code
Replies
4
Views
299
FGaxha
F
C
  • Question
A Bookmark to return to the same row when exiting and opening the application
Replies
8
Views
152
Edgar_
Edgar_
C
  • Question
Excel Userform Listbox Search issues
Replies
3
Views
102
Akuini
Akuini
P
  • Question
ListBox Click to textbox & delete row
Replies
0
Views
308
pure vito
P
I
  • Question
Listbox not being populate when code is run
Replies
4
Views
256
ipbr21054
I

Forum statistics

Threads
1,214,591
Messages
6,120,426
Members
448,961
Latest member
nzskater

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