Chisholm
07-14-2008, 12:46 PM
Hi all, I'm trying to create a user form which copies text from text boxes and places them in the appropriate columns of the last row in the sheet.
A problem arises when I try to add a combobox to the form... I used modified version of the KB article:
Address: "http://www.vbaexpress.com/kb/getarticle.php?kb_id=824"
Title: "Fill combobox with ordered list"
I've got the box and form to function, however a problem remains with the combobox.
The combobox is listing the contents of the named range that i'm using, except it is repeating duplicate entries, something that it looks like it was designed not to do.
Here's the VBA code I've compiled thus far:
'Place all code in the Userform
Option Explicit
Dim FArray()
Dim DataList As Range
Dim MyList As String
Private Sub UserForm_Initialize()
Dim Found As Long, i As Long
Dim cel As Range
'Set Range Name to suit
MyList = "Bid_To"
Set DataList = Range(MyList)
ReDim FArray(DataList.Cells.Count)
i = -1
For Each cel In DataList
On Error Resume Next
Found = Application.WorksheetFunction.Match(CStr(cel), FArray, 0)
If Found > 0 Then GoTo Exists
i = i + 1
FArray(i) = cel
Exists:
Found = 0
Next
ReDim Preserve FArray(i)
Call BubbleSort(FArray)
ComboBox1.ListRows = i + 1
ComboBox1.List() = FArray
End Sub
Private Sub ComboBox1_AfterUpdate()
Dim MyAdd As String
Dim Found As Long
On Error Resume Next
Found = Application.WorksheetFunction.Match(ComboBox1, FArray, 0)
If Found > 0 Then
DoEvents
Else
DataList.End(xlDown).Offset(1) = ComboBox1
Set DataList = Union(DataList, DataList.End(xlDown))
MyAdd = "=" & ActiveSheet.Name & "!" & DataList.Address
ActiveWorkbook.Names.Add Name:=MyList, _
RefersTo:=MyAdd
End If
End Sub
Private Sub CommandButton1_Click()
Cells(Cells.Rows.Count, 4).End(xlUp).Offset(1) = ComboBox1
Set DataList = Nothing
Unload UserForm1
End Sub
Sub BubbleSort(MyArray As Variant)
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim j As Integer
Dim Temp As String
Dim List As String
First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For j = i + 1 To Last
If MyArray(i) > MyArray(j) Then
Temp = MyArray(j)
MyArray(j) = MyArray(i)
MyArray(i) = Temp
End If
Next j
Next i
End Sub
Private Sub cmd_add_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Fixed Sheet")
'find first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
'check for a part number
If Trim(Me.txt_job.Value) = "" Then
Me.txt_job.SetFocus
MsgBox "Please enter a Job"
Exit Sub
End If
'copy the data to the database
ws.Cells(iRow, 1).Value = Me.txt_date.Value
ws.Cells(iRow, 2).Value = Me.txt_bid.Value
ws.Cells(iRow, 3).Value = Me.txt_job.Value
ws.Cells(iRow, 4).Value = Me.txt_total.Value
ws.Cells(iRow, 5).Value = Me.txt_est1.Value
ws.Cells(iRow, 6).Value = Me.txt_est2.Value
ws.Cells(iRow, 7).Value = Me.txt_status.Value
ws.Cells(iRow, 8).Value = Me.txt_gross.Value
ws.Cells(iRow, 11).Value = Me.txt_site.Value
ws.Cells(iRow, 12).Value = Me.txt_type.Value
'clear the data
Me.txt_date.Value = ""
Me.txt_bid.Value = ""
Me.txt_job.Value = ""
Me.txt_total.Value = ""
Me.txt_est1.Value = ""
Me.txt_est2.Value = ""
Me.txt_status.Value = ""
Me.txt_gross.Value = ""
Me.txt_site.Value = ""
Me.txt_job.Value = ""
Me.txt_date.SetFocus
End Sub
Private Sub cmd_close_Click()
Unload Me
End Sub
Private Sub UserForm_Click()
End Sub
I've included a sample spreadsheet, which doesn't have the original dataset I'm using, and doesn't have the correct userform, but it does reproduce the problem.
A problem arises when I try to add a combobox to the form... I used modified version of the KB article:
Address: "http://www.vbaexpress.com/kb/getarticle.php?kb_id=824"
Title: "Fill combobox with ordered list"
I've got the box and form to function, however a problem remains with the combobox.
The combobox is listing the contents of the named range that i'm using, except it is repeating duplicate entries, something that it looks like it was designed not to do.
Here's the VBA code I've compiled thus far:
'Place all code in the Userform
Option Explicit
Dim FArray()
Dim DataList As Range
Dim MyList As String
Private Sub UserForm_Initialize()
Dim Found As Long, i As Long
Dim cel As Range
'Set Range Name to suit
MyList = "Bid_To"
Set DataList = Range(MyList)
ReDim FArray(DataList.Cells.Count)
i = -1
For Each cel In DataList
On Error Resume Next
Found = Application.WorksheetFunction.Match(CStr(cel), FArray, 0)
If Found > 0 Then GoTo Exists
i = i + 1
FArray(i) = cel
Exists:
Found = 0
Next
ReDim Preserve FArray(i)
Call BubbleSort(FArray)
ComboBox1.ListRows = i + 1
ComboBox1.List() = FArray
End Sub
Private Sub ComboBox1_AfterUpdate()
Dim MyAdd As String
Dim Found As Long
On Error Resume Next
Found = Application.WorksheetFunction.Match(ComboBox1, FArray, 0)
If Found > 0 Then
DoEvents
Else
DataList.End(xlDown).Offset(1) = ComboBox1
Set DataList = Union(DataList, DataList.End(xlDown))
MyAdd = "=" & ActiveSheet.Name & "!" & DataList.Address
ActiveWorkbook.Names.Add Name:=MyList, _
RefersTo:=MyAdd
End If
End Sub
Private Sub CommandButton1_Click()
Cells(Cells.Rows.Count, 4).End(xlUp).Offset(1) = ComboBox1
Set DataList = Nothing
Unload UserForm1
End Sub
Sub BubbleSort(MyArray As Variant)
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim j As Integer
Dim Temp As String
Dim List As String
First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For j = i + 1 To Last
If MyArray(i) > MyArray(j) Then
Temp = MyArray(j)
MyArray(j) = MyArray(i)
MyArray(i) = Temp
End If
Next j
Next i
End Sub
Private Sub cmd_add_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Fixed Sheet")
'find first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
'check for a part number
If Trim(Me.txt_job.Value) = "" Then
Me.txt_job.SetFocus
MsgBox "Please enter a Job"
Exit Sub
End If
'copy the data to the database
ws.Cells(iRow, 1).Value = Me.txt_date.Value
ws.Cells(iRow, 2).Value = Me.txt_bid.Value
ws.Cells(iRow, 3).Value = Me.txt_job.Value
ws.Cells(iRow, 4).Value = Me.txt_total.Value
ws.Cells(iRow, 5).Value = Me.txt_est1.Value
ws.Cells(iRow, 6).Value = Me.txt_est2.Value
ws.Cells(iRow, 7).Value = Me.txt_status.Value
ws.Cells(iRow, 8).Value = Me.txt_gross.Value
ws.Cells(iRow, 11).Value = Me.txt_site.Value
ws.Cells(iRow, 12).Value = Me.txt_type.Value
'clear the data
Me.txt_date.Value = ""
Me.txt_bid.Value = ""
Me.txt_job.Value = ""
Me.txt_total.Value = ""
Me.txt_est1.Value = ""
Me.txt_est2.Value = ""
Me.txt_status.Value = ""
Me.txt_gross.Value = ""
Me.txt_site.Value = ""
Me.txt_job.Value = ""
Me.txt_date.SetFocus
End Sub
Private Sub cmd_close_Click()
Unload Me
End Sub
Private Sub UserForm_Click()
End Sub
I've included a sample spreadsheet, which doesn't have the original dataset I'm using, and doesn't have the correct userform, but it does reproduce the problem.