Quote:
Originally Posted by gmayor
Unfortunately you can't adapt the code as you have done, with regard to the list box. If you want to insert multiple values from the list box then you must add each selected value to the bookmark. There are a number of ways of doing this, but the simplest is to add them to a text string and then add the text string to the bookmark e.g. as follows.
Don't forget to declare the string strText in the DIM statements at the top of the macro!
I assume that you removed any reference to the text box from the userform code.Debug > Compile Project should reveal any glaring coding errors.
Have a good Christmas.
Code:
.Show
If .Tag = 1 Then 'OK button pressed
With .ListBox1
'locate the selected items from the list box and add to a string
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
If strText = "" Then
strText = strText & .List(i)
Else
strText = strText & vbCr & .List(i)
End If
End If
Next i
End With
FillBM "BM1", strText
End If
|
As far as i know i deleted everything that belonged to the text box.
I declared the strText as string in the start with Dim strText as String. When i run the macro i can choose and multiselect the options in the populated listbox. But once i click ok i get an error. When i click the debug button this line of code is highlighted:
Code:
If .Tag = 1 Then 'OK button pressed
My Whole Code in the module:
Code:
Option Explicit
Sub ShowMyForm()
Dim oFrm As UserForm1
Dim i As Integer
Dim strText As String
Dim strWorkbook As String
'the workbook path and name
strWorkbook = "C:\Users\censored\Desktop\Testen\Tabellemitprozesse.xlsx"
'Give the userform a name the macro will use
Set oFrm = New UserForm1
With oFrm
'Call the function to fill the listbox with the workbook sheet 1 column 1
xlFillList .ListBox1, 1, strWorkbook, "Tabelle1", True, True
With .ListBox1
.MultiSelect = fmMultiSelectExtended
.ListIndex = -1
End With
.Show
If .Tag = 1 Then 'OK button pressed
With .ListBox1
'locate the selected items from the list box and add to a string
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
If strText = "" Then
strText = strText & .List(i)
Else
strText = strText & vbCr & .List(i)
End If
End If
Next i
End With
FillBM "bm1", strText
End If
End With
Unload oFrm
End Sub
Public Sub FillBM(strBMName As String, strValue As String)
Dim oRng As Range
With ActiveDocument
On Error GoTo lbl_Exit
Set oRng = .Bookmarks(strBMName).Range
oRng.Text = strValue
oRng.Bookmarks.Add strBMName
End With
lbl_Exit:
Exit Sub
End Sub
Public Function xlFillList(ListOrComboBox As Object, _
iColumn As Long, _
strWorkbook As String, _
strRange As String, _
RangeIsWorksheet As Boolean, _
RangeIncludesHeaderRow As Boolean, _
Optional PromptText As String = "[Select Item]")
'Graham Mayor - http://www.gmayor.com - Last updated - 20 Sep 2018
'ListOrComboBox is the name of the list or combo box to be filled
'iColumn is the column in the sheet (or the range) to be displayed in the list/combo box
'strWorkbook is the full path of the workbook containing the data
'strRange is the name of the worksheet or named range containing the data
'RangeIsWorksheet - set to True if the range 'strRange' is a worksheet
' or False if it is a named range
'RangeIncludesHeaderRow - Set to True is the Worksheet or named range contains a header row
'PromptText - Use a text string here to add your preferred prompt text to a combobox.
'The PromptText is not used for ListBoxes.
Dim RS As Object
Dim CN As Object
Dim numrecs As Long, q As Long
Dim strWidth As String
If RangeIsWorksheet = True Then
strRange = strRange & "$]"
Else
strRange = strRange & "]"
End If
Set CN = CreateObject("ADODB.Connection")
If RangeIncludesHeaderRow Then
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Else
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
End If
Set RS = CreateObject("ADODB.Recordset")
RS.CursorLocation = 3
RS.Open "SELECT * FROM [" & strRange, CN, 2, 1 'read the data from the worksheet
With RS
.MoveLast
numrecs = .RecordCount
.MoveFirst
End With
With ListOrComboBox
.ColumnCount = RS.Fields.Count
If RS.RecordCount > 0 Then
.Column = RS.GetRows(numrecs)
End If
strWidth = vbNullString
For q = 1 To .ColumnCount
If q = iColumn Then
If strWidth = vbNullString Then
strWidth = .Width - 4 & " pt"
Else
strWidth = strWidth & .Width - 4 & " pt"
End If
Else
strWidth = strWidth & "0 pt"
End If
If q < .ColumnCount Then
strWidth = strWidth & ";"
End If
Next q
.ColumnWidths = strWidth
If TypeName(ListOrComboBox) = "ComboBox" Then
.AddItem PromptText, 0
If Not iColumn - 1 = 0 Then .Column(iColumn - 1, 0) = PromptText
.ListIndex = 0
End If
End With
lbl_Exit:
'Cleanup
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
Exit Function
End Function