[VBA] Σύγκριση τιμών ComboBox από το ίδιο το ComboBox.

[anestaki]

Έχω μια αναπτυσσόμενη λίστα στην όπια θα ήθελα να συγκρίνω τις τιμές της με των εαυτό της δηλαδή να αποκλείσω διπλό έγραφες.
Παράλληλα να εγράφη μια νέα τιμή και να κάνη Refresh.

Dim i As Long
i = Φύλλο16.Range("c" & Rows.Count).End(xlUp).Row
If i > 2 Then Φύλλο16.Range("c" & i + 1).Value = ComboBox2
If ComboBox2.ListIndex = ComboBox2 Then Φύλλο16.Range("c" & i + 1).Value = ""

[Tasos]

Πέρασε τον παρακάτω κώδικα σε μια φόρμα με ένα σύνθετο πλαίσιο με το όνομα "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
        

[anestaki]

Καλησπέρα
Τάσο σε ευχαριστώ που συνεχίζεις να με υποστηρίζεις
Ενώ δουλεύει κανονικά όπως μου είπες όταν το χρησιμοποιώ στην δική μου φόρμα δεν λειτουργεί
Και θα ήθελα να μου υπόδειξη το λάθος μου.

Option Explicit
Private rng As Range, c As Range

Private Sub UserForm_Initialize()
ComboBox1.List() = Φύλλο3.Range("AA1:AA24").Value
ComboBox1 = Φύλλο3.Range("G7").Value
TextBox1 = Φύλλο3.Range("l7").Value
TextBox2 = Φύλλο3.Range("n7").Value
TextBox2 = Format(Me.TextBox2, "dd-mm-yyyy")
TextBox3 = Φύλλο3.Range("j10").Value
TextBox4 = Φύλλο3.Range("j11").Value
TextBox5 = Φύλλο3.Range("j12").Value
TextBox6 = Φύλλο3.Range("j13").Value
TextBox7 = Φύλλο3.Range("j14").Value
TextBox8 = Φύλλο3.Range("j15").Value
TextBox9 = Φύλλο3.Range("j16").Value
TextBox10 = Φύλλο3.Range("j17").Value
ComboBox2 = Φύλλο3.Range("g15").Value
ComboBox3 = Φύλλο3.Range("g16").Value
ComboBox4 = Φύλλο3.Range("g17").Value
With Φύλλο16
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 ComboBox2, rng
Else
Set rng = .Cells(1, 3)
End If
End With
ComboBox3.List = ComboBox2.List
ComboBox4.List = ComboBox2.List
ComboBox5.List = ComboBox2.List
ComboBox6.List = ComboBox2.List
ComboBox8.List = ComboBox2.List
ComboBox9.List = ComboBox2.List
ComboBox10.List = ComboBox2.List
ComboBox19.List = ComboBox2.List


End Sub
Private Sub ComboBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If Trim(ComboBox2.Text) = "" Then Exit Sub
ComboBox2.Text = Trim(ComboBox2.Text)
If KeyCode = vbKeyReturn Then
Set c = rng.Find(ComboBox2.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 = ComboBox2.Text
ComboBox2.AddItem rng.Text
Else
rng(rng.Rows.Count).Value = ComboBox2.Text
FillCombo ComboBox2, rng
End If
ComboBox2.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

[Tasos]

Το πλήκτρο Enter θα πυροδοτήσει το συμβάν KeyUp() μόνο αν δεν μεταφερθεί η εστίαση σε άλλο πεδίο (AutoTab).


Αντικατέστησε λοιπόν τον κώδικα:

Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
        .......................
        .......................
End Sub

με τον παρακάτω:

Private Sub ComboBox1_AfterUpdate()
    If Trim(ComboBox1.Text) = "" Then Exit Sub
    ComboBox1.Text = Trim(ComboBox1.Text)
    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
                ComboBox1.AddItem rng.Text
            Else
                rng(rng.Rows.Count).Value = ComboBox1.Text
                FillCombo ComboBox1, rng
            End If
            ComboBox1.Value = rng(rng.Rows.Count).Text
        End If
    End If
End Sub

Καλή συνέχεια!

Τάσος

[anestaki]

Καλημέρα σε όλους
Τάσο σε ευχαριστώ παρά πολύ μπορεί να το έψαχνα μέρες.
Φιλικά Γιώργος