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)

Παράθεση:

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

Καλημέρα

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

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

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

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

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

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

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

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

Κώδικας:

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 γραμμές ακαριαία

Παράθεση:

Αρχική Δημοσίευση από 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

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

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