[VBA] Αυτόματη συμπλήρωση κωδικών

[sxatzig]

Παρακαλώ αν κάποιος μπορεί να βοηθήσει.........

Εχω ένα αρχείο με το όνομα Βιβλίo 4 ΤΕΣΤ.xlsm
Εχει δύο φύλα εργασίας με ονόματα : ΚΩΔΙΚΟΣ & ΑΝΤΙΚΕΙΜΕΝΑ.
Στο φύλλο ΚΩΔΙΚΟΣ υπάρχει ένας κατάλογος αντικειμένων στην στήλη C και η συντομογραφία τους στην στήλη B.
Στο φύλλο ΑΝΤΙΚΕΙΜΕΝΑ στην στήλη Κ υπάρχει μια λίστα με αντικείμενα.
Σκοπός είναι να μεταφέρεται στην στήλη J (μετά απο αναζήτηση στο φύλλο ΚΩΔΙΚΟΣ) αυτόματα η συντομογραφία που αντιστοιχεί στην κάθε λέξη ή φράση που μόλις έχω πληκτρολογήσει στην στήλη K.
Αν δεν υπάρχει αντιστοίχιση (εκ παραλείψεως ή λάθους) μεταξύ του αντικειμένου και συντομογραφίας τότε το αντίστοιχο κελί γίνεται κόκκινο.

Δημιουργήθηκε ένας κώδικας VBA με την βοήθεια της τεχνητής νοημοσύνης (δηλώνω ότι με την VBA είμαι άσχετος).

Παρ όλα αυτά ο κώδικας δεν λειτουργεί.
Ο κώδικας είναι ο ακόλουθος:

Function RemoveMultipleSpaces(text As String) As String
On Error Resume Next
Do While InStr(1, text, " ") > 0
text = Replace(text, " ", " ")
Loop
RemoveMultipleSpaces = Trim(text)
On Error GoTo 0
End Function

Function RemoveZeroWidthSpaces(text As String) As String
On Error Resume Next
RemoveZeroWidthSpaces = Replace(text, ChrW(8203), "")
On Error GoTo 0
End Function

Function CleanString(text As Variant) As String
On Error Resume Next
If IsNull(text) Then
CleanString = ""
Exit Function
End If

If IsError(text) Then
CleanString = ""
Exit Function
End If

If IsEmpty(text) Then
CleanString = ""
Exit Function
End If

CleanString = RemoveMultipleSpaces(CStr(text))
CleanString = RemoveZeroWidthSpaces(CleanString)
On Error GoTo 0
End Function

Function FindCode(deviceName As String, codeSheet As Worksheet) As String
On Error Resume Next
Dim lastRow As Long, i As Long
Dim cellValue As Variant

deviceName = CleanString(deviceName)
deviceName = StrConv(deviceName, vbUnicode)

With codeSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 2 To lastRow
cellValue = .Cells(i, "C").Value

If Not IsError(cellValue) Then
If Not IsEmpty(cellValue) Then
cellValue = StrConv(CleanString(CStr(cellValue)), vbUnicode)
If StrComp(deviceName, cellValue, vbBinaryCompare) = 0 Then
FindCode = StrConv(CStr(.Cells(i, "B").Value), vbUnicode)
Exit Function
End If
End If
End If
Next i
End With

FindCode = ""
On Error GoTo 0
End Function

Sub ApplyFindCode()
Dim wsObjects As Worksheet, wsCodes As Worksheet
Dim lastRow As Long, i As Long
Dim abbreviation As String
Dim cellValueK As Variant

On Error GoTo 0 'Καθαρισμός τυχόν προηγούμενων σφαλμάτων

'Έλεγχος ύπαρξης φύλλων
If Not SheetExists("ΚΩΔΙΚΟΣ") Then
MsgBox "Δεν βρέθηκε το φύλλο 'ΚΩΔΙΚΟΣ'.", vbCritical
Exit Sub
End If

If Not SheetExists("ΑΝΤΙΚΕΙΜΕΝΑ") Then
MsgBox "Δεν βρέθηκε το φύλλο 'ΑΝΤΙΚΕΙΜΕΝΑ'.", vbCritical
Exit Sub
End If

Set wsCodes = ThisWorkbook.Worksheets("ΚΩΔΙΚΟΣ")
Set wsObjects = ThisWorkbook.Worksheets("ΑΝΤΙΚΕΙΜΕΝΑ")

With wsObjects
lastRow = .Cells(.Rows.Count, "K").End(xlUp).Row
For i = 2 To lastRow
abbreviation = ""

' ***ΑΠΟΛΥΤΟΣ ΧΕΙΡΙΣΜΟΣ ΣΦΑΛΜΑΤΩΝ: ΑΚΡΙΒΩΣ ΠΡΙΝ ΤΗΝ ΑΝΑΓΝΩΣΗ ΤΗΣ ΤΙΜΗΣ***
On Error Resume Next ' ΕΝΕΡΓΟΠΟΙΗΣΗ ΧΕΙΡΙΣΜΟΥ ΣΦΑΛΜΑΤΩΝ
cellValueK = .Cells(i, "K").Value ' ΠΡΟΣΠΑΘΟΥΜΕ ΝΑ ΠΑΡΟΥΜΕ ΤΗΝ ΤΙΜΗ
If Err.Number <> 0 Then ' ΕΛΕΓΧΟΣ ΑΝ ΠΡΟΕΚΥΨΕ ΣΦΑΛΜΑ
Debug.Print "ApplyFindCode: Σφάλμα στο κελί K" & i & ": " & Err.Description & " - Τύπος: " & TypeName(.Cells(i, "K"))
Err.Clear ' ΚΑΘΑΡΙΣΜΟΣ ΤΟΥ ΣΦΑΛΜΑΤΟΣ
On Error GoTo 0 'Απενεργοποίηση χειρισμού σφαλμάτων
GoTo NextIteration 'Πάμε στην επόμενη επανάληψη
End If
On Error GoTo 0 'Απενεργοποίηση χειρισμού σφαλμάτων

'Συνεχίζουμε μόνο αν δεν υπήρξε σφάλμα στην ανάγνωση
If Not IsEmpty(cellValueK) And Not IsNull(cellValueK) Then
If VarType(cellValueK) <> vbString Then
On Error Resume Next
cellValueK = CStr(cellValueK)
If Err.Number <> 0 Then
Debug.Print "ApplyFindCode: Σφάλμα CStr στο κελί K" & i & ": " & Err.Description
Err.Clear
ElseIf IsNull(cellValueK) Then
Debug.Print "ApplyFindCode: Μετά την CStr το κελί K" & i & " είναι Null."
Else
cellValueK = Trim(cellValueK)
cellValueK = StrConv(CleanString(cellValueK), vbUnicode)
abbreviation = FindCode(cellValueK, wsCodes)
If abbreviation = "" Then
Debug.Print "ApplyFindCode: Δεν βρέθηκε αντιστοιχία για το κελί K" & i
End If
End If
On Error GoTo 0
Else
cellValueK = Trim(cellValueK)
cellValueK = StrConv(CleanString(cellValueK), vbUnicode)
abbreviation = FindCode(cellValueK, wsCodes)
If abbreviation = "" Then
Debug.Print "ApplyFindCode: Δεν βρέθηκε αντιστοιχία για το κελί K" & i
End If
End If
End If

NextIteration:
.Cells(i, "J").Value = abbreviation
If abbreviation = "" Then
.Cells(i, "J").Interior.Color = vbRed
Else
.Cells(i, "J").Interior.Color = xlNone
End If
Next i
End With
End Sub

Function SheetExists(sheetName As String) As Boolean
On Error Resume Next
SheetExists = Not IsError(ThisWorkbook.Worksheets(sheetName))
On Error GoTo 0
End Function


Όταν τον εκτελώ με την εντολή Run επιστρέφει το εξής: Compile error: ByRef argument type mismatch
Επίσης μου εμφανίζει με κίτρινο χρώμα το: Sub ApplyFindCode() και με μπέ χρώμα το: cellValueK .

Αν κάποιος ανακαλύψει τι φταίει: παράκληση ας μου δώσει ολόκληρο τον κώδικα και όχι αποσπασματικές διορθώσεις.
Ευχαριστώ

[ChrisGT7]

Καλησπέρα Στέλιο,

Θεωρώ πως το ζητούμενό σου όπως το περιγράφεις, είναι πολύ απλό για να χρησιμοποιήσεις τόσο πολύπλοκο κώδικα.

Για αρχή, δοκίμασε στο ΑΝΤΙΚΕΙΜΕΝΑ!J2 τον τύπο:

=INDEX(Φύλλο2!B:B;MATCH(K2;Φύλλο2!C:C;0)) 

και σύρε τον και στα υπόλοιπα κελιά. Το "Λάθος Αντικείμενο" δε βρέθηκε ως είδος στο Φύλλο2.

Αν παρόλα αυτά χρειάζεσαι υποχρεωτικά τον κώδικα, τότε θα τον ελέγξω για τα λάθη που αναφέρεις.

[Tasos]

Καλό μεσημέρι σε όλους!

Στέλιο θα πρέπει να χρησιμοποιήσεις μια πιο αποδοτική και αξιόπιστη μέθοδο καταχώρησης ενός προϊόντος.

Υπάρχουν πολλές πιθανότητες τυπογραφικού/ορθογραφικού σφάλματος κατά την καταχώρηση ενός όρου, πχ. "Ραδιόφώνου παρελκόμενα".

Ωστόσο νομίζω ότι το ζητούμενο σου λύνεται με απλές συναρτήσεις αναφοράς του Excel.

Έστω ότι στο παράδειγμα που επισύναψες υπάρχει το φύλλο "ΚΩΔΙΚΟΣ".
Στο κελί J2 του φύλλου "ΑΝΤΙΚΕΙΜΕΝΑ" επικόλλησε τον παρακάτω τύπο:

=IFERROR(INDEX(ΚΩΔΙΚΟΣ!B:B;MATCH(K2;ΚΩΔΙΚΟΣ!C:C;0));"??")

Ο τύπος αυτός επιστρέφει τον κωδικό που αντιστοιχεί στην περιγραφή του προϊόντος που θα πληκτρολογήσεις από το φύλλο "ΚΩΔΙΚΟΣ".

Αν δεν υπάρχει ο κωδικός θα σου επιστρέψει μηδέν (0) ενώ αν δεν ταιριάζει η περιγραφή του προϊόντος που θα πληκτρολογήσεις, θα σου επιστρέψει "??".

Όσο για την επισήμανση σφάλματος στη στήλη J, μπορείς να χρησιμοποιήσεις μορφοποίηση υπό όρους.

Αν χρειαστείς κάτι άλλο δώσε μας περισσότερα στοιχεία για να σε βοηθήσουμε.


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

Τάσος

[sxatzig]

Ευχαριστώ και πάλι
Λειτουργεί η προτεινόμενη λύση σου, όμως όλες οι καταχωρήσεις που έχω είναι με κεφαλαία γράμματα και ορισμένες με μικρά ή και τα δύο.
Πως το αντιμετωπίζουμε αυτό ?.

[Tasos]

Δεν υπάρχει πρόβλημα αφού δεν γίνεται διάκριση ανάμεσα σε πεζά-κεφαλαία.

Θα έχεις πρόβλημα αν δεν συμφωνούν τα φωνήεντα με σημεία στίξης.

Φιλικά

Τάσος

[sxatzig]

Αγαπητέ Τάσσο
Ο η συνάρτηση: =IFERROR(INDEX(ΚΩΔΙΚΟΣ!B:B;MATCH(K2;ΚΩΔ? ?ΚΟΣ!C:C;0));"??")
σε μένα δεν λειτουργεί. Μου επιστρέφει "??"
Η λέξη "ΚΩΔΙΚΟΣ" γραφτηκε σωστά.
Κοίταξε σε παρακαλώ τι δεν πάει καλά.
Ευχαριστώ

Ακυρο ΛΕΙΤΟΥΡΓΕΙ. είχα γράψει κατα λάθος "ΚΩΔΙΚΟΣ" αντί για το σωστό "ΚΩΔΙΚΟΙ"
Ευχαριστώ

Έχω να επισημάνω ότι θα ήταν πιό πρόσφορο και πολύ εύκολα αντιληπτό ότι αν :
1. Το επιστρεφόμενο "0" γινόταν κόκκινο και (περίπτωση που δεν υπάρχει κωδικός)
2. το "??" γινόταν κίτρινο. (περίπτωση λανθασμένου κωδικού)

[Tasos]

Στέλιο μου όλα καλά.

Η συνάρτηση θα λειτουργήσει μόνο αν στο παράδειγμα που επισύναψες υπάρχει το φύλλο "ΚΩΔΙΚΟΣ".

Μάλλον θα πρέπει να μετονομάσεις το Φύλλο2 σε "ΚΩΔΙΚΟΣ" για να έχεις αποτελέσματα.

Δες παράδειγμα στο συνημμένο.

Τάσος

[sxatzig]

Μπορείς να το κάνεις να βγάζει χρώματα ?

[Tasos]

Για την επισήμανση σφάλματος στη στήλη K, μπορείς να χρησιμοποιήσεις μορφοποίηση υπό όρους.