Forum - Μορφοποίηση Μορφοποίηση σε νόμισμα

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [Μορφοποίηση] Μορφοποίηση σε νόμισμα (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/3050-morfopoiisi-se-nomisma.html)

Μορφοποίηση σε νόμισμα

Γεια σας. Μήπως υπάρχει τρόπος γράφοντας στο κελί ένα ποσό παραλείποντας το κόμμα (,) και να το παίρνει αυτόματα? Παράδειγμα : Θέλω να γράφω στο κελί 15434 και να πατάω enter και αυτό να μου γράφει αυτόματα 154,34 €

Βοήθεια ?
Ευχαριστώ εκ των προτέρων

Καλησπέρα Γιώργο!

Υπάρχει μια επιλογή (σε επίπεδο εφαρμογής όμως) που κάνει ακριβώς αυτό που ζητάς.

Πήγαινε στις επιλογές του Excel > Για προχωρημένους και τσέκαρε το πλαίσιο ελέγχου με την ετικέτα: Αυτόματη εισαγωγή υποδιαστολής.

Προσοχή! Η επιλογή της Αυτόματης εισαγωγής υποδιαστολής ισχύει για όλα βιβλία που θα ανοιχτούν.

Μια άλλη λύση θα ήταν η χρήση κώδικα VBA με την προϋπόθεση ότι οι μακροεντολές στην εφαρμογή θα πρέπει να είναι ενεργοποιημένες.

Επίσης η λύση με VBA ακυρώνει τη δυνατότητα αναίρεσης ενεργειών του βιβλίου εργασίας.

Αν καταλήξεις ότι θέλεις να χρησιμοποιήσεις VBA τότε κάνε δεξί κλικ στην καρτέλα του φύλλου που σε ενδιαφέρει και επίλεξε "Προβολή κώδικα".

Στο παράθυρο που θα εμφανιστεί επικόλλησε τον παρακάτω κώδικα:

Κώδικας:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.CountLarge > 1 Then Exit Sub

    If Target.Row < 1 Then Exit Sub

    If IsNumeric(Target.Value) Then

        Select Case Target.Column
         'Προσάρμοσε παρακάτω τα νούμερα των στηλών

        'όπου θα εφαρμόζεται η εισαγωγή υποδιαστολής.

            Case 2, 3, 4, 5, 6, 7  '<---τα νούμερα των στηλών

                Application.EnableEvents = False

                Target.Value = Target.Value / 100

                Application.EnableEvents = True

        End Select

    End If

End Sub

Ο κώδικας αυτός τρέχει αυτόματα κάθε φορά που θα αλλάξει η τιμή ενός κελιού στις
στήλες 2, 3, 4, 5, 6, 7 και μετά την πρώτη γραμμή.

Μπορείς να προσθέσεις ή να αφαιρέσεις νούμερα στηλών στον κώδικα διατηρώντας πάντα την σύνταξη όπως φαίνεται παραπάνω.

Μορφοποίησε τις στήλες με μορφή αριθμού "νομισματική μονάδα"
.
Καλή συνέχεια!

Τάσος

Παράθεση:

Αρχική Δημοσίευση από Tasos (Μήνυμα 17675)

Κώδικας:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.CountLarge > 1 Then Exit Sub

    If Target.Row < 1 Then Exit Sub

    If IsNumeric(Target.Value) Then

        Select Case Target.Column
         'Προσάρμοσε παρακάτω τα νούμερα των στηλών

        'όπου θα εφαρμόζεται η εισαγωγή υποδιαστολής.

            Case 2, 3, 4, 5, 6, 7  '<---τα νούμερα των στηλών

                Application.EnableEvents = False

                Target.Value = Target.Value / 100

                Application.EnableEvents = True

        End Select

    End If

End Sub

Ευχαριστώ
Με βοηθάει εν μέρει με το κώδικα όχι με την ρύθμιση. Το ιδανικό θα ήταν να γίνεται μόνο σε κάποια συγκεκριμένα κελιά τα οποία δεν έιναι στην ίδια σειρά η στήλη αλλα άν δεν γίνεται και πάλι ευχαριστώ
:thumbup1:

Γιώργο στο συνημμένο παράδειγμα υπάρχουν δύο προσεγγίσεις που καλύπτουν το ζητούμενο

Στο φύλλο Περιοχές κελιών υπάρχουν περιοχές (με κίτρινο φόντο) στις οποίες έχουν δοθεί τα ονόματα : NameOfRange1, NameOfRange2, NameOfRange3, NameOfRange4 και NameOfRange5.
Ο κώδικας που επιτρέπει την εισαγωγή υποδιαστολής είναι:

Κώδικας:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim CanRun As Boolean

    If Target.CountLarge > 1 Then Exit Sub

    If Target.Row < 1 Then Exit Sub

    If IsNumeric(Target.Value) Then

        If Target.Value <> 0 Then

            If Not Intersect(Target, Range("NameOfRange1")) Is Nothing Or _

               Not Intersect(Target, Range("NameOfRange2")) Is Nothing Or _

               Not Intersect(Target, Range("NameOfRange3")) Is Nothing Or _

               Not Intersect(Target, Range("NameOfRange4")) Is Nothing Or _

               Not Intersect(Target, Range("NameOfRange5")) Is Nothing Then

                Application.EnableEvents = False

                Target.Value = Target.Value / 100

                Application.EnableEvents = True

            End If

        End If

    End If

End Sub

Στο φύλλο Διευθύνσεις κελιών υπάρχουν μεμονωμένα κελιά (επίσης με κίτρινο φόντο για καλύτερη σήμανση) με διευθύνσεις: "A3", "B4", "C5", "D8", "D10" και "D15"
Ο κώδικας που επιτρέπει την εισαγωγή υποδιαστολής στο φύλλο αυτό είναι:

Κώδικας:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.CountLarge > 1 Then Exit Sub

    If Target.Row < 1 Then Exit Sub

    If IsNumeric(Target.Value) Then

        If Target.Value <> 0 Then

            Select Case Target.Address(False, False)

                Case "A3", "B4", "C5", "D8", "D10", "D15"

                    Application.EnableEvents = False

                    Target.Value = Target.Value / 100

                    Application.EnableEvents = True

            End Select

        End If

    End If

End Sub

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

Τάσος

Τέλεια !!

Ευχαριστώ για τον χρόνο που αφιερώσατε να με βοηθήσετε

Ότι ήθελα

Να είσαι καλά Γιώργο!

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

Τάσος