Forum

Forum (https://www.ms-office.gr/forum/)
-   Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)
-   -   [VBA] Αντικατασταση Γραμματων (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/3710-antikatastasi-grammaton.html)

manolis 05-06-15 06:30
Αντικατασταση Γραμματων
 
Καλημέρα σε όλη την παρέα

Εχω φτιάξει την παρακάτω μακρο για να αντικαταστήσω ελληνικούς χαρακτήρες με αγγλικούς.

Sub ReplaceLetters i()

Columns("H:H").Select
Cells.Replace What:="Α", Replacement:="A"
Cells.Replace What:="Β", Replacement:="B"
Cells.Replace What:="Ε", Replacement:="E"
............................
End sub

Tο προβλημα μου είναι οτι ενω θέλω να γίνει η αλλαγή στη στήλη που επιλέγω , αυτο γίνεται σε όλες τις στήλες.

Τι έχω κάνει λάθος ?

Επίσης θα ήθελα αν γίνεται οτι αλλαγες γίνουν στα γράμματα να επισημανθούν πχ να γίνουν κόκκινα τα γράμματα που θα αλλαχθούν

Ευχαριστώ


ευχαριστώ

kapetang 05-06-15 11:50
Καλημέρα

Μανώλη, προτείνω να δοκιμάσεις τον παρακάτω κώδικα:

Κώδικας:
Option Explicit

Sub ReplaceGreekChars()
    Dim rng As Range, c As Range, i As Long
    Dim x As String, y As String

    Set rng = Range("H:H")

    For Each c In rng
        If Len(c) > 0 Then
            x = c: y = x
            y = Replace(Replace(Replace(y, "Α", "A"), "Β", "B"), "Ε", "E")
            If x <> y Then
                c = y
                For i = 1 To Len(x)
                    If Mid(x, i, 1) <> Mid(y, i, 1) Then
                        c.Characters(Start:=i, Length:=1).Font.Color = -16777024
                    End If
                Next
            End If
        End If
    Next
End Sub
Φιλικά/Γιώργος

kapetang 05-06-15 14:49
Και μια παραλλαγή του κώδικα, που βελτιώνει την ταχύτητα:

Κώδικας:
Option Explicit

Sub ReplaceGreekChars()
    Dim rng As Range, c As Range, i As Long
    Dim x As String, y As String

    Set rng = Range("H1:H" & Cells(Cells.Rows.Count, 8).End(xlUp).Row)
    Application.ScreenUpdating = False
    For Each c In rng
        If Len(c) > 0 Then
            x = c: y = x
            y = Replace(Replace(Replace(y, "Α", "A"), "Β", "B"), "Ε", "E")
            If x <> y Then
                c = y
                For i = 1 To Len(x)
                    If Mid(x, i, 1) <> Mid(y, i, 1) Then
                        c.Characters(Start:=i, Length:=1).Font.Color = -16777024
                    End If
                Next
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

manolis 05-06-15 22:04
Καλησπέρα σε όλη την παρέα

Γιώργο σε ευχαριστώ για τις λύσεις που πρότεινες. Τις εφάρμοσα στο αρχείο μου και δουλευουν μια χαρά.

Οσο για το λάθος :fryingpan: που έκανα στον δικό μου κώδικα βρήκα τi είναι.
Επρεπε αντι για cells έπρεπε να να βάλω selection

Καλό βράδυ


Η ώρα είναι 01:36.

Ms-Office.gr - ©2000 - 2025, Jelsoft Enterprises Ltd.


Search Engine Optimization by vBSEO 3.3.2