[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 .

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