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
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
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: 12
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
You must log in or register to reply here.

Similar threads

C
  • Question Question
Searching using TextBox and ListBox
Replies
1
Views
230
campbell1093
C
I
  • Question Question
Select Listbox value to be then taken to customer on worksheet
Replies
1
Views
103
ipbr21054
I
I
  • Solved
Also have the row number shown in Listbox on userform advice
Replies
7
Views
74
NoSparks
N
GomaPile
  • Question Question
Listbox1 Error
Replies
4
Views
256
GomaPile
GomaPile
M
  • Question Question
Re-produce code to copy last row from listbox on userform to sheet
Replies
3
Views
143
MKLAQ
M

Forum statistics

Threads
1,223,885
Messages
6,175,187
Members
452,616
Latest member
intern444

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