Need Multiselect LIstBox to Split to new row instead of Word Wrap

0

I have a UserForm with two listboxes.  Three buttons to add, remove, and transfer.  It works great except for when the selected LB items are too long for the cells.  I need to have them split into a new line for each value that exceeds max character length.  I found some code that will do that for a specific line of text, but despite my best efforts, I can't find a way to incorporate the two.

Transfer button:

Private Sub JLParaTransfer_Click()
    Dim lItem As Long, lRows As Long, lCols As Long
    Dim bSelected As Boolean
    Dim lColLoop As Long, lTransferRow As Long
    JLParaCB2.Value = False
    JLParaCB2.Value = True
    lTransferRow = 0
    lRows = JLParaLB2.ListCount - 1
    lCols = JLParaLB2.ColumnCount - 1
    For lItem = 0 To lRows
        If JLParaLB2.Selected(lItem) = True Then
           bSelected = True
           Exit For
        End If
    Next
    If bSelected = True Then
       With ActiveCell
            For lItem = 0 To lRows             'Posts the new data
                If JLParaLB2.Selected(lItem) = True Then
                   lTransferRow = lTransferRow + 1
                   For lColLoop = 0 To lCols
                       .Cells(lTransferRow, lColLoop + 1) = JLParaLB2.List(lItem, lColLoop)
                   Next lColLoop
                End If
            Next
       End With
       UnHook_Mouse 'Turns off the mouse
       Unload Me
    End If
    JLParaCB2.Value = False
End Sub

The split code:

 Dim s, m, v, o1, o2, j
    m = 17                                              'max characters per line
    s = "Amazingly few discotheques provide jukeboxes"  'the text
    v = Split(s, " ")
    
    For j = 0 To UBound(v)
        If o2 = "" Then
            If Len(v(j)) > m Then
                o1 = o1 & v(j) & vbCrLf
                j = j + 1
                If j > UBound(v) Then Exit For
            End If
        End If
        If Len(o2 & v(j)) > m Then
            o1 = o1 & Trim(o2) & vbCrLf
            o2 = ""
            j = j - 1
        Else
            o2 = o2 & v(j) & " "
        End If
        If j = UBound(v) Then
            o1 = o1 & Trim(o2)
        End If
    Next
    MsgBox o1
Any help is greatly appreciated!
Answer
Discuss

Answers

0
Selected Answer

Other than my "SplitString" function I couldn't test the code below for lack of supporting data. However, I am confident that you will be able to do any final adjustments should they be needed. Let me know if you need help.

Private Sub JLParaTransfer_Click()
    ' 16 Sep 2017
    
    Dim lItem As Long, lRows As Long, lCols As Long
    Dim bSelected As Boolean
    Dim lColLoop As Long, lTransferRow As Long
    Dim Sp() As String, i As Long
    Dim C As Long                           ' count columns
    
'    JLParaCB2.Value = False
    JLParaCB2.Value = True
    lTransferRow = 0
    lRows = JLParaLB2.ListCount - 1
    lCols = JLParaLB2.ColumnCount - 1
    For lItem = 0 To lRows
        If JLParaLB2.Selected(lItem) = True Then
           bSelected = True
           Exit For
        End If
    Next
    If bSelected = True Then
       With ActiveCell      ' ========= shouldn't this be ActiveSheet ?????
            For lItem = 0 To lRows             'Posts the new data
                If JLParaLB2.Selected(lItem) = True Then
                    lTransferRow = lTransferRow + 1
                    C = 1
                    For lColLoop = 0 To lCols
                        ' here: the maximum textbox width is 17
                        If SplitString(JLParaLB2.List(lItem, lColLoop), 17, Sp) Then
                            For i = 0 To UBound(Sp)
                                .Cells(lTransferRow, C) = Sp(i)
                                C = C + 1
                            Next i
                        End If
                    Next lColLoop
                End If
            Next
       End With
       UnHook_Mouse 'Turns off the mouse
       Unload Me
    End If
    JLParaCB2.Value = False
End Sub
Private Function SplitString(ByVal S As String, _
                             ByVal MaxChar As Long, _
                             Sp() As String) As Boolean
    ' 16 Sep 2017
    ' Sp() is assigned the split string
    ' function returns True if S was not null string
    
    Dim Fun() As String                 ' function return variable
    Dim i As Long
    Dim n As Long, m As Long
    
    ReDim Sp(100)                       ' guaranteed larger than required
    
    i = -1
    Do While Len(S)
        n = InStr(S, " ")
        If n = 0 Then n = MaxChar + 1
        m = InStr(S, "-")
        If m = 0 Then m = MaxChar + 1
        n = Application.Min(n, m, Len(S), MaxChar)
        i = i + 1
        Sp(i) = Left(S, n)
        S = Mid(S, n + 1)
    Loop
    
    If i >= 0 Then
        ReDim Preserve Sp(i)
        n = 0                               ' index of Fun()
        ReDim Fun(n)
        m = 0                               ' index of Sp()
        
        Do
            If Len(Fun(n)) + Len(Sp(m)) > MaxChar Then
                Fun(n) = Trim(Fun(n))
                n = n + 1
                ReDim Preserve Fun(n)
            End If
            Fun(n) = Fun(n) & Sp(m)
            m = m + 1
        Loop While m <= i
        
        Sp = Fun
        SplitString = True
    End If
End Function

Please take a look at the line "With ActiveCell" which I have marked. Note that the function "SplitString" splits on hyphen as well as space and could be expanded to split on Chr(160) if that is an issue with you. Observe that I put the maximum string length in the function call, not the function, so as to make the function itself more versatile.

Discuss

Discussion

First, Thank you so much for the reply!   
I moved the Function into its own module and made it public.  The code works, but only halfway- it stops at max character length, but the rest of each line is lost in the abyss.

I use ActiveCell because it's the only way it'll drop the output directly where the current active cell is which is exactly what I want.  I'll include the rest of the userform code to make testing easier.  
2 ListBoxes each with their own select all check box
Add Remove Transfer Command Buttons (you already have Transfer code)

Dim i As Integer
 
Private Sub UserForm_Initialize()
    JLParaLB1.MultiSelect = 1
    JLParaLB2.MultiSelect = 1
    'iGblControlType = nMyControlTypeLISTBOX
    'Set myGblUserForm = Me
    'Set myGblControlObject = Me.JLParaLB1
    'Hook_Mouse
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
   ' UnHook_Mouse
End Sub
 
'*Add*
 
Private Sub JLParaAdd_Click()
    For i = 0 To JLParaLB1.ListCount - 1
        If JLParaLB1.Selected(i) = True Then
           JLParaLB2.AddItem JLParaLB1.List(i)
        End If
    Next i
    JLParaCB1.Value = True
    JLParaCB1.Value = False
End Sub
Sentinal4 (rep: 2) Sep 16, '17 at 2:48 pm
'*Left Sel All*
 
Private Sub JLParaCB1_Click()
    If JLParaCB1.Value = True Then
       For i = 0 To JLParaLB1.ListCount - 1
           JLParaLB1.Selected(i) = True
       Next i
    End If
    If JLParaCB1.Value = False Then
       For i = 0 To JLParaLB1.ListCount - 1
           JLParaLB1.Selected(i) = False
       Next i
    End If
End Sub
 
'*Right Sel All*
 
Private Sub JLParaCB2_Click()
    If JLParaCB2.Value = True Then
       For i = 0 To JLParaLB2.ListCount - 1
           JLParaLB2.Selected(i) = True
       Next i
    End If
    If JLParaCB2.Value = False Then
       For i = 0 To JLParaLB2.ListCount - 1
           JLParaLB2.Selected(i) = False
       Next i
    End If
End Sub
 
'*Remove*
 
Private Sub JLParaRemove_Click()
    Dim Counter As Integer
    Counter = 0
    For i = 0 To JLParaLB2.ListCount - 1
        If JLParaLB2.Selected(i - Counter) Then
           JLParaLB2.RemoveItem (i - Counter)
           Counter = Counter + 1
        End If
    Next i
    JLParaCB2.Value = False
End Sub
Sentinal4 (rep: 2) Sep 16, '17 at 2:48 pm
'With ActiveCell' is an overkill in your code because there is only a single reference to it in the block ending on 'End With'. Therefore it would be better and clearer to delete the block and add the reference to the line where it is needed.
ActiveCell.Cells(lTransferRow, lColLoop + 1) = JLParaLB2.List(lItem, lColLoop)

That's an odd way of referencing because it is indirect. I would have defined the target cell in the ActiveSheet with the help of 'ActiveCell.Row' and 'ActiveCell.Column' but that may be a matter of taste. The point to take note of is that 'ActiveCell.Cells(1, 1)' defines the Activecell itself. Since lTransferRow seems to be 1 in your code the ActiveCell's row is specified indirectly. lColLoop is a minimum of 1, but you haven't disclosed how many columns there are in your list boxes. Your code would start writing in the ActiveCell and continue in the columns to the right. I tried to use extra cells in the same row for partial strings.
Variatus (rep: 1413) Sep 16, '17 at 9:50 pm
The function 'SplitString' is fully tested and works fine. It doesn't matter that you moved it, but I don't understand "it stops at max character length". Of course, I couldn't test the function with a real 'JLParaLB2.List(lItem, lColLoop)' string. I used this sub for testing.
Private Sub TestSplitString()
    Dim Sp() As String
    Dim i As Integer
    
    If SplitString("This is my test-string for testing", 10, Sp) Then
        For i = 0 To UBound(Sp)
            Debug.Print Sp(i)
        Next i
    End If
End Sub
Variatus (rep: 1413) Sep 16, '17 at 10:02 pm
It works!  I discovered that the company's sheet already had a split function defined that was doing something else and it was causing a conflict.  What made it really fun was that it didn't give me an error.  It just simply refused to do anything.  So I tried it out on a blank workbook and it works great!  It puts the continuation (overflow if you prefer) in the next column.  I need it on the row just beneath the first half- like a word wrap on steroids, but I should be able to play with it and get that to work.  Thank you very much for your help!!!   I'll get the two functions to get along.  I would love to have tested this more completely, but I'm way busy right now... I'll work on this more when I get home.  Take care!    P.S.  You were right- I took to heart what you said about Active Cell vs Sheet and made the changes.  Works!  Thank you!

Sentinal4 (rep: 2) Sep 17, '17 at 5:27 pm
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login