Πέρασε τον παρακάτω κώδικα σε μια φόρμα με ένα σύνθετο πλαίσιο με το όνομα "Combobox1" και δοκίμασε.
Ο κώδικας αυτός: - Γεμίζει και ταξινομεί τα στοιχεία του "Combobox1" με δεδομένα από τη στήλη C του φύλλου με το
κωδικό όνομα Sheet1 αγνοώντας τυχόν κενά κελιά. - Αν πληκτρολογηθεί τιμή που δεν υπάρχει στη λίστα, μετά από πάτημα του Enter θα ερωτηθεί ο
χρήστης αν θέλει να καταχωρηθεί νέα εγγραφή στο φύλλο.
- Μετά από την καταχώρηση το σύνθετο πλαίσιο ενημερώνεται, ταξινομείται εκ νέου και η νέα εγγραφή θα επιλεγεί.
Option Explicit
Private rng As Range, c As Range
Private Sub UserForm_Initialize()
With Sheet1
If Application.CountA(Range(.Cells(2, 3), .Cells(2, 3).End(xlDown))) Then
Set rng = Range(.Cells(2, 3), .Cells(Rows.Count, 3).End(xlUp))
FillCombo ComboBox1, rng
Else
Set rng = .Cells(1, 3)
End If
End With
End Sub
Private Sub ComboBox1_KeyUp( _
ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
If Trim(ComboBox1.Text) = "" Then Exit Sub
ComboBox1.Text = Trim(ComboBox1.Text)
If KeyCode = vbKeyReturn Then
Set c = rng.Find(ComboBox1.Text, LookIn:=xlValues)
If c Is Nothing Then
If MsgBox("Η εγγραφή αυτή δεν υπάρχει στη λίστα." & _
" Να την καταχωρήσω;", vbQuestion + vbYesNo) = vbYes Then
Set rng = rng.Resize(rng.Rows.Count + 1, 1)
If rng.Row = 1 Then
Set rng = rng.Offset(1).Resize(1, 1)
rng.Value = ComboBox1.Text
'rng.Value = Application.Proper(ComboBox1.Text) 'το πρώτο γράμμα της λέξης κεφαλαίο
ComboBox1.AddItem rng.Text
Else
rng(rng.Rows.Count).Value = ComboBox1.Text
'rng(rng.Rows.Count).Value = Application.Proper(ComboBox1.Text) 'το πρώτο γράμμα της λέξης κεφαλαίο
FillCombo ComboBox1, rng
End If
ComboBox1.Value = rng(rng.Rows.Count).Text
End If
End If
End If
End Sub
Private Sub FillCombo( _
ByVal cbo As MSForms.ComboBox, _
ByVal rng As Range)
Dim c As Range, i As Long, x As Long, sw1, sw2, Itm
Dim Coll As New Collection
On Error Resume Next
For Each c In rng
Coll.Add c.Value, c.Text
Next
On Error GoTo 0
For i = 1 To Coll.Count - 1
For x = i + 1 To Coll.Count
If UCase(Coll(i)) > UCase(Coll(x)) Then
sw1 = Coll(i)
sw2 = Coll(x)
Coll.Add sw1, before:=x
Coll.Add sw2, before:=i
Coll.Remove i + 1
Coll.Remove x + 1
End If
Next x
Next i
cbo.Clear
For Each Itm In Coll
cbo.AddItem Itm
Next Itm
End Sub | 