Announcement

Collapse
No announcement yet.

ListBox: transfer selected values to range and delete deselected values from range

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • ListBox: transfer selected values to range and delete deselected values from range

    Hello,

    I would like to select and deselect values from a listbox (located on "Table"), and those values to be transferred to a range of cells located on a different worksheet (B7 to below) called "Criteria". Currently, my code works well when I select values, but if I unselect them, the values still appear on the range.

    Basically, I would like range(B7 to below) to always show what is currently being selected in the listbox.

    How would you change this code to reflect that?

    Thanks a lot

    Code:
    Private Sub ListBox1_Click()
    Dim a, i&, r&, c&
    
    
    
    
        
    With ListBox1
        a = .List
        For r = 0 To UBound(a)
          If .Selected(r) Then
            For c = 0 To UBound(a, 2)
              a(i, c) = .List(r, c)
            Next
            i = i + 1
          End If
        Next
      End With
      If i Then
        ' Copy selected rows to destination
        Worksheets("Criteria").Range("B7").Resize(i, UBound(a, 2) + 1) = a
        
        
      Else
        MsgBox "Items are not selected", vbExclamation
      End If
    End Sub

  • #2
    Re: ListBox: transfer selected values to range and delete deselected values from rang

    Maybe this
    Code:
    Private Sub ListBox1_Click()
        Dim a, b, i&, r&, c&
              
        With ListBox1
            a = .List
            Sheets("Criteria").Range("B7").Resize(.ListCount, UBound(a, 2) + 1).ClearContents
            For r = 0 To UBound(a)
                If .Selected(r) Then
                    i = i + 1: ReDim Preserve b(1 To UBound(a, 2) + 1, 1 To i)
                    For c = 0 To UBound(a, 2)
                        b(c + 1, i) = .List(r, c)
                    Next
                End If
            Next
        End With
        If i > 0 Then
             ' Copy selected rows to destination
            Sheets("Criteria").Range("B7").Resize(UBound(b, 2), i) = Application.Transpose(b)
        Else
            MsgBox "Items are not selected", vbExclamation
        End If
        
    End Sub
    We now have a reputation system in place. It can be found on the 'Star' icon on the bottom left hand side of the post

    Comment

    Working...
    X