VBA for Listbox to current selected cell

GeneBF

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

GeneBF

New Member
Joined
Jun 28, 2022
Messages
31
Office Version
  1. 365
Platform
  1. Windows
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)
1657171090687.png
 
Upvote 0

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

GeneBF

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
15,818
Office Version
  1. 2013
Platform
  1. Windows
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:
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

Hukam

New Member
Joined
Jul 3, 2022
Messages
3
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2011
  7. 2010
  8. 2007
  9. 2003 or older
Platform
  1. Windows
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.
 

Attachments

  • stocks.png
    stocks.png
    125.7 KB · Views: 4
Upvote 0

GeneBF

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

Forum statistics

Threads
1,186,516
Messages
5,958,300
Members
438,348
Latest member
JS050

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
Top