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/3823-allagi-sto-deytero-dekadiko-psifio.html)

Quenya

04-09-15 18:07

αλλαγη στο δευτερο δεκαδικο ψηφιο

Γεια σας , σε κενη στηλη υπαρχει η δυνατοτητα προτου εισαχθουν αριθμοι να οριστει η αλλαγη του δευτερου δεκαδικου απο 3 4 6 7 σε 5 και 1 2 8 9 σε 0 ?
Αν οχι σε κενη τοτε αφου εισαχθουν ? ευχαριστω

kapetang

05-09-15 11:21

1 Συνημμένο(α)

Καλημέρα

Μορφέα, δες μια πρόταση στο συνημμένο.

Ελπίζω να δουλεύει στην αγγλική έκδοση.

Από περιέργεια σε τι σε εξυπηρετεί το ζητούμενο;

Φιλικά/Γιώργος

Quenya

05-09-15 22:18

Παράθεση:

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

Ο κωδικας μια χαρα δουλευει , αλλα εγω δεν ανελυσα οπως επρεπε το ακριβες ζητουμενο.
οι αριθμοι που ερχονται στην στηλη εχουν 2 δεκαδικα, σε ολη την κλιμακα 0-9 .
τα ψηφια 8 κ 9 να τα κλεινει στην επομενη δεκαδα και οχι προς τα κατω , αναλυτικα,
1,61 1,62 = 1,60 1,63 1,64 1,66 1,67 = 1,65 1,68 1,69 = 1,70 ετσι επρεπε να το ζητησω

ειναι ομως καλυτερη η εξης παραλλαγη 1,61 1,62 1,63 1,64 = 1,65 και 1,66 1,67 1,68 1,69 = 1,70 και να μην αλλαζει το δευτερο δεκαδικο οταν ειναι 5 η 0. να τρεχει σε μηκος 1500 κελιων διοτι δεν ειμαι κ πολυ σιγουρος οτι μπορω να το αλλαξω, πολυ προχω θεματα αυτα εχω μεινει αγαλμα με αυτα που βλεπω να φτιαχνονται. ευχαριστω πολυ για την βοηθεια Γιωργο.

Spirosgr

05-09-15 23:16

ο κώδικας στο φύλλο, συμβάν Change:

Κώδικας:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Columns.Count > 1 Then Exit Sub

    If Target.Rows.Count > 1 Then Exit Sub

    If Intersect(Target, Columns(1)) Is Nothing Then

        Exit Sub

    Else

        Target = Application.WorksheetFunction.Ceiling(Target, 0.05)

    End If

End Sub

Σημείωση:
Ισχύει για εισαγωγή αριθμών στην στήλη Α.
Χρησιμοποιεί την CEILING σε πολλαπλάσιο 0,05 προς τα επάνω.

kapetang

06-09-15 00:01

1 Συνημμένο(α)

Καλησπέρα

Μορφέα, δες το συνημμένο.

Είναι προσαρμοσμένο στην πρώτη εκδοχή στρογγυλοποίησης.

Για τη δεύτερη χρησιμοποίησε τον κώδικα του Σπύρου.

Φιλικά/Γιώργος

Quenya

06-09-15 00:10

Παράθεση:

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

ο κώδικας στο φύλλο, συμβάν Change:

Κώδικας:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Columns.Count > 1 Then Exit Sub

    If Target.Rows.Count > 1 Then Exit Sub

    If Intersect(Target, Columns(1)) Is Nothing Then

        Exit Sub

    Else

        Target = Application.WorksheetFunction.Ceiling(Target, 0.05)

    End If

End Sub

Σημείωση:
Ισχύει για εισαγωγή αριθμών στην στήλη Α.
Χρησιμοποιεί την CEILING σε πολλαπλάσιο 0,05 προς τα επάνω.

Εκανα αντιγραφη του φυλλου εξελ με την προταση κωδικα του Γιωργου σε νεο φυλλο εξελ
πηγα στον κωδικα τον εσβησα κ τον αντεγραψα τον παραπανω που προτεινες
το στρογγυλεμα γινετε οπως ειναι το ζητουμενο, ομως προεκυψε ενα νεο θεμα και ενα ακομα που δεν ειχα προσεξει ουτε στην προηγουμενη προταση , αυτα ειναι
οι δυο κωδικες δουλευουν εαν πληκτρολογηθουν αριθμοι μεσα στα κελια και μονο,
ζητω λυση ωστε να επεμβαινουν και να αλλαζουν τους αριθμους που θα ερχονται στη στηλη με αντιγραφη απο αλλο φυλλο , καθως εαν ειναι να γραφω 1000 και πλεον κελια δεν κερδιζω τιποτα απο χρονο
το δευτερο που προεκυψε και αφορα τη δευτερη λυση ειναι οτι καθε αριθμος που πληκτρολογω στο κελι γονατιζει τον επεξεργαστη στο 95% ( α6 6400Κ κ 8G RAM )και κολλαει το πσ για 30 δευτερα περιπου
η πρωτη λυση εστελνε τον επεξεργαστη καπου στο 50 %
οπως κ να χει ο κωδικας πρεπει να επεμβαινει σε δεδομενα τα οποια θα επικολουνται στη στηλη προερχομενα απο αλλη στηλη αλλου φυλλου. ευχαριστω

Quenya

06-09-15 00:42

Παράθεση:

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

Γιωργο , η νεα προταση ακουει το ζητουμενο στρογγυλοποιησης στη κοντινοτερη δεκαδα, αλλα δεν μπορω να βρω αν υπαρχει καποιος τροπος επικολλησης , των εισερχομενων αριθμων ωστε να μετατρεπει οσους εχουν δευτερο δεκαδικο διαφορετικο του 5 η 0 . ευχαριστω..

Spirosgr

06-09-15 00:45

Ο υπολογιστής σου «γονατίζει», είτε γιατί είναι «μικρός» είτε γιατί σε κάθε αλλαγή (εισαγωγή),
τρέχουν κι άλλες συναρτήσεις.
Με τεστ σε 120000 γραμμές, ο κώδικας, τρέχει ακαριαία.
Όσο για τα ζητούμενα σου, καλό είναι να λες ξεκάθαρα και ακριβώς, αυτό που θέλεις.

Quenya

06-09-15 01:11

Παράθεση:

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

η αληθεια ειναι οτι πραγματι εχω ενα σοβαρο θεμα να εξηγησω με σαφηνεια τα ζητουμενα.
ζηταω σε κενη στηλη να υπαρχει η δυνατοτητα προτου εισαχθουν αριθμοι στην περιοχη α1 εως α1500 (εχουν 2 δεκαδικα ) με τη μεθοδο της επικολλησης, οι οποιοι προερχονται απο αλλο φυλλο εξελ , να οριστει η αλλαγη του δευτερου δεκαδικου απο 1 2 3 4 σε 5 και 6 7 8 9 σε 0 ? αυτο ειναι το ζητουμενο . ευχαριστω πολυ για τον χρονο σας.

kapetang

06-09-15 08:51

1 Συνημμένο(α)

Καλημέρα

Μορφέα, μετά τη διευκρίνιση του ζητούμενου, το πρόβλημα είναι απλό.

Δε χρειάζεται αντιγραφή και επικόλληση και κώδικας VBA.

Αρκεί στη στήλη A1:A1500 να βάλλουμε ένα τύπο.

Δες το συνημμένο.

Φιλικά/Γιώργος

Quenya

06-09-15 11:04

Παράθεση:

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

Καλημερα Γιωργο, υπεροχα , αυτο ειναι η λυση , :drinks:
εκαστος στο ειδος σχετικα με απλο του θεματος,
και εγω ειμαι ασχετος, μαθαινω μονο αν καποιος βρισκετε διπλα μου και μου δειχνει,
απο βιβλιο να το κανω πραξη ουτε καν,
καθενας με τις αδυναμιες του, τις δεχετε κ προχωραει

που χρησιμευει τωρα αυτο που εφτιαξες
κανει ομαδοποιηση σε 150 ξεχωριστα επιτοκια προερχομενα απο 1500 και βαλε προιοντα , σε 30 βασικες μοναδες επιτοκιων ανα 0,05.
Σας ευχαριστω παρα πολυ που λυνετε τα προβληματα μου.

Spirosgr

06-09-15 12:37

Ο κώδικας στο φύλλο

Κώδικας:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim i As Long

    Dim nRow As Long

    nRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

    If Application.CutCopyMode = xlCopy Then

        If Intersect(Target, Columns(1)) Is Nothing Then

            Exit Sub

        Else

            Application.EnableEvents = False

            For i = 1 To nRow

                Sheet1.Cells(i, 1).Value = Application.WorksheetFunction.Ceiling(Sheet1.Cells(i, 1).Value, 0.05)

            Next i

            Application.EnableEvents = True

            Application.CutCopyMode = False

        End If

    End If

End Sub

Σημειώσεις:
Αντιγράφουμε πχ μια στήλη με 50.000 κελιά
Πάμε στο A1 και κάνουμε επικόλληση
Μετατρέπονται αυτόματα οι αξίες σε πολλαπλάσιο 0,05
Χρόνος εκτέλεσης για 50.000 γραμμές 0,5 sec
Χρόνος εκτέλεσης για 1.500 γραμμές ακαριαία

Quenya

06-09-15 13:21

Παράθεση:

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

Ο κώδικας στο φύλλο

Κώδικας:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim i As Long

    Dim nRow As Long

    nRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

    If Application.CutCopyMode = xlCopy Then

        If Intersect(Target, Columns(1)) Is Nothing Then

            Exit Sub

        Else

            Application.EnableEvents = False

            For i = 1 To nRow

                Sheet1.Cells(i, 1).Value = Application.WorksheetFunction.Ceiling(Sheet1.Cells(i, 1).Value, 0.05)

            Next i

            Application.EnableEvents = True

            Application.CutCopyMode = False

        End If

    End If

End Sub

Χαιρετε Σπυρο , παρακαλω να ρωτησω τον κωδικα που εχεις γραψει απο πανω τον κανω αντιγραφη απο εδω , και τον επικολλω που ? στη θεση προβολη κωδικα με δεξι κλικ στο φυλλο ?

Spirosgr

06-09-15 13:50

Ναι, στην ίδια θέση με τον προηγούμενο, τον οποίο διαγράφεις.
Επίσης, διαγράφεις και όποιο άλλο συμβάν Worksheet_Change, έχει τυχόν ξεχαστεί...

Η ώρα είναι 22:11.

Search Engine Optimization by vBSEO 3.3.2