Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Замена английских букв на русские, Скорость выполнения макроса
 
#1
29.10.2024 19:32:37
Здравствуйте уважаемые специалисты,

Есть код для замены английских букв на похожие русские, но на больших данных макрос выполняется 25 сек. Хотелось бы быстрый вариант макроса. Буду признателен если сможете помочь.
Код
Sub ReplaceMe()
Dim T As Double: T = Now

On Error Resume Next
With Sheets("1")
    Dim LC As Long: LC = .Cells(Rows.Count, "D").End(xlUp).Row
    Dim RNG As Range
    For Each RNG In .Range("D1:E" & LC)

    If InStr(1, RNG, "A") > 0 Then RNG.Value = Replace(RNG, "A", "А")
    If InStr(1, RNG, "B") > 0 Then RNG.Value = Replace(RNG, "B", "В")
    If InStr(1, RNG, "E") > 0 Then RNG.Value = Replace(RNG, "E", "Е")
    If InStr(1, RNG, "K") > 0 Then RNG.Value = Replace(RNG, "K", "К")
    If InStr(1, RNG, "M") > 0 Then RNG.Value = Replace(RNG, "M", "М")
    If InStr(1, RNG, "H") > 0 Then RNG.Value = Replace(RNG, "H", "Н")
    If InStr(1, RNG, "O") > 0 Then RNG.Value = Replace(RNG, "O", "О")
    If InStr(1, RNG, "P") > 0 Then RNG.Value = Replace(RNG, "P", "Р")
    If InStr(1, RNG, "C") > 0 Then RNG.Value = Replace(RNG, "C", "С")
    If InStr(1, RNG, "T") > 0 Then RNG.Value = Replace(RNG, "T", "Т")
    Next RNG
End With

MsgBox Now - T
End Sub
 
 
 
#2
29.10.2024 19:36:32
Забираете данные в память, обрабатываете, выгружаете обратно
 
 
 
#3
29.10.2024 19:38:54
nilske, В макросах не очень разбираюсь. Можете, дать ссылку на такие примеры?  
 
 
 
#4
29.10.2024 19:45:20
Шерзод Маткаримов, Можно ведь слепо менять сразу по всему диапазону, типа как тут:
Код
    With Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("P:Q"))
        .Replace Chr(160), " ", 2
        .Replace Chr(10), "", 2
        .Replace Chr(13), "", 2
        .Replace ".", ",", 2
    End With
 
 
 
#5
29.10.2024 19:48:11
примерно так
https://www.planetaexcel.ru/forum/?PAGE_NAME=message&FID=1&TID=66282&MID=s
 
 
 
#6
29.10.2024 20:33:21
Hugo, Так работает быстрее. За 10 сек. обработал 100 000 строк. Спасибо.
 
 
 
#7
29.10.2024 21:40:21
Шерзод Маткаримов,  пересчёт и обновление экрана отключили? И события, если вдруг есть такие макросы.
 
 
 
#8
30.10.2024 07:41:27
Цитата
nilske написал:
Забираете данные в память, обрабатываете, выгружаете обратно
Есть резон попробовать, но и есть ограничение. В ячейках должны быть значения а не формулы.

Вариант нужно проверять, но возможно будет еще быстрее если  при обработке сперва объединить массив в строку, провести замены и снова переведя в массив выгрузить на лист, проделывая проделыв это по каждому столбцу диапазона.
По вопросам из тем форума, личку не читаю.
 
 
 
#9
30.10.2024 11:57:38
Спасибо за ответы. Сделал обработку в памяти, но я плохо разбираюсь в массивах. Сейчас заменяет только одну букву (последнюю строку "Т"). Как исправить, чтобы заменить все 11 букв?
Код
Sub REPCHAR()
    Dim Massive(2), DATA As Variant, RES As Variant, LC As String, I As Long, N As Long
    Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")
    
    With Sheets("1")
    LC = .Cells(.Rows.Count, "D").End(xlUp).Row
    DATA = .Range("D1:E" & LC).Value
    RES = .Range("D1:E" & LC).Value
    For I = 1 To 2
        If Not Dic.Exists(DATA(I, 2)) Then
            Massive(2) = Replace(DATA(I, 2), "A", "А")
            Massive(2) = Replace(DATA(I, 2), "B", "В")
            Massive(2) = Replace(DATA(I, 2), "E", "Е")
            Massive(2) = Replace(DATA(I, 2), "K", "К")
            Massive(2) = Replace(DATA(I, 2), "M", "М")
            Massive(2) = Replace(DATA(I, 2), "H", "Н")
            Massive(2) = Replace(DATA(I, 2), "O", "Щ")
            Massive(2) = Replace(DATA(I, 2), "P", "Р")
            Massive(2) = Replace(DATA(I, 2), "C", "С")
            Massive(2) = Replace(DATA(I, 2), "X", "Х")
            Massive(2) = Replace(DATA(I, 2), "T", "Т")
            Dic(DATA(I, 2)) = Massive
        End If
    Next I
    For N = 1 To UBound(DATA)
        On Error Resume Next
            RES(N, 1) = Dic(DATA(N, 2))(2)
        On Error GoTo 0
    Next N
    
    .Range("D1:E" & LC) = RES
    End With
End Sub
 
 
 
#10
30.10.2024 12:32:17
Код
            Massive(2) = Replace(DATA(I, 2), "A", "А")
            Massive(2) = Replace(Massive(2), "B", "В")
            Massive(2) = Replace(Massive(2), "E", "Е")
            Massive(2) = Replace(Massive(2), "K", "К")
            Massive(2) = Replace(Massive(2), "M", "М")
            Massive(2) = Replace(Massive(2), "H", "Н")
            Massive(2) = Replace(Massive(2), "O", "Щ")
            Massive(2) = Replace(Massive(2), "P", "Р")
            Massive(2) = Replace(Massive(2), "C", "С")
            Massive(2) = Replace(Massive(2), "X", "Х")
            Massive(2) = Replace(Massive(2), "T", "Т")
 
 
 
#11
30.10.2024 12:52:30
irabel, Всё еще только одну "Т" заменяет. И почему только "Т"? Попробовал поставить строку с "Т" и в начале, и в середину списка, но обрабатывает только "Т". Может надо очистить память, в конце?
Изменено: Шерзод Маткаримов - 30.10.2024 13:05:53
 
 
 
#12
30.10.2024 16:31:52
Шерзод Маткаримов, выложите, пожалуйста, фрагмент файла (100 строк), на котором можно будет тестировать те или иныe решения.
Тогда можно будет размножить количество строк до "боевого" (100 000) и уже делать выводы об эффективности.
Владимир
 
 
 
#13
30.10.2024 20:03:52
брррр ,а словарь то тут к чему? Вроде про уникальность вопроса не стояло?

Почему обработка идет только по одному столбцу массива?
По вопросам из тем форума, личку не читаю.
 
 
 
#14
31.10.2024 08:33:08
Всем спасибо за ответы. Решение найдено.
Делюсь результатом. Обрабатывает 100 000 строк за 2 сек.
Код
Sub REPCHAR()
Dim T As Double: T = Now
    
    Dim DATA As Variant, LC As Long, R As Long, C As Long
    With ActiveSheet
        LC = .Cells(.Rows.Count, "D").End(xlUp).Row
        DATA = .Range("D1:E" & LC).Value
        For R = LBound(DATA, 1) To UBound(DATA, 1)
            For C = LBound(DATA, 2) To UBound(DATA, 2)
                DATA(R, C) = Replace(DATA(R, C), "A", "А")
                DATA(R, C) = Replace(DATA(R, C), "B", "В")
                DATA(R, C) = Replace(DATA(R, C), "E", "Е")
                DATA(R, C) = Replace(DATA(R, C), "K", "К")
                DATA(R, C) = Replace(DATA(R, C), "M", "М")
                DATA(R, C) = Replace(DATA(R, C), "H", "Н")
                DATA(R, C) = Replace(DATA(R, C), "O", "О")
                DATA(R, C) = Replace(DATA(R, C), "P", "Р")
                DATA(R, C) = Replace(DATA(R, C), "C", "С")
                DATA(R, C) = Replace(DATA(R, C), "X", "Х")
                DATA(R, C) = Replace(DATA(R, C), "T", "Т")
            Next C
        Next R
        .Range("D1:E" & LC).Value = DATA
    End With


MsgBox Now - T
End Sub
 
 
 
#15
31.10.2024 10:42:21
Шерзод Маткаримов

Замена английских букв на русские
Спасибо Вам, что открыли этот вопрос для обсуждения.
У Вас нет текста или Примера в виде файла Excel. Хотелось бы наглядно посмотреть как это выглядит на листе Excel.
Могли бы Вы предоставить файл Пример в Excel?
Из всего написанного я понял назначение этого кода так:
Находящийся текст в определённом диапазоне листа на английском языке переводится или так: транслитерация с английского на русский.
Если это так, то можно сделать не в диапазоне столбцов и строк, а по выделенному фрагменту строк и столбцов.
В любом случае можно воспользоваться Вашим готовым файлом примером?

Спасибо Вам!
 
 
 
#16
31.10.2024 12:02:51
Цитата
написал:
по выделенному фрагменту строк и столбцов
Код
Option Explicit

Sub REPCHAR_Selection()
    If TypeName(Selection) = "Range" Then REPCHAR Selection
End Sub

Sub REPCHAR(rr As Range)
    Dim arr As Variant
    arr = InitArr("ABEKMHOPCXT", "АВЕКМНОРСХТ")

    Dim ru As Range
    On Error Resume Next
    Set ru = Intersect(rr, rr.Parent.UsedRange)
    On Error GoTo 0
    If ru Is Nothing Then Exit Sub
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim rArea As Range
    For Each rArea In ru.Areas
        REPCHAR_Area rArea, arr
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Sub REPCHAR_Area(rr As Range, arr As Variant)
    Dim T As Double: T = Now
    
    Dim DATA As Variant, LC As Long, R As Long, C As Long
    If rr.Cells.CountLarge = 1 Then
        ReDim DATA(1 To 1, 1 To 1)
        DATA(1, 1) = rr.Value
    Else
        DATA = rr.Value
    End If
    Dim ya As Long
    Dim xa As Long
    For R = LBound(DATA, 1) To UBound(DATA, 1)
        For C = LBound(DATA, 2) To UBound(DATA, 2)
            For ya = 1 To UBound(arr, 1)
                For xa = 1 To UBound(arr, 2) Step 2
                    If InStr(1, DATA(R, C), arr(ya, xa), vbBinaryCompare) > 0 Then
                        DATA(R, C) = Replace(DATA(R, C), arr(ya, xa), arr(ya, xa + 1))
                    End If
                Next
            Next
        Next C
    Next R
    rr.Value = DATA
End Sub

Private Function InitArr(se As String, sr As String)
    Dim arr As Variant
    ReDim arr(1 To Len(se), 1 To 4)
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        arr(ya, 1) = UCase(Mid(se, ya, 1))
        arr(ya, 2) = UCase(Mid(sr, ya, 1))
        arr(ya, 3) = LCase(Mid(se, ya, 1))
        arr(ya, 4) = LCase(Mid(sr, ya, 1))
    Next
    InitArr = arr
End Function
 
 
 
#17
31.10.2024 13:54:31
МатросНаЗебре,

Большое Вам СПАСИБО!

Выделил английские слова, запустил макрос, что то не пошло, не произошло изменение английских слов на русскую транскрипцию.

Изменено: Cristal - 31.10.2024 14:23:13 (Не проверил работу макроса и отписал)
 
 
 
#18
31.10.2024 15:15:56
Цитата
написал:
Из всего написанного я понял назначение этого кода так:Находящийся текст в определённом диапазоне листа на английском языке переводится или так: транслитерация с английского на русский.
Это не транслитерация, это исправление опечаток, когда в тексте, который должен содержать только буквы русского алфавита, есть буквы латинского алфавита (внешне похожие на своих "тёзок").
Изменено: sokol92 - 31.10.2024 15:17:28
Владимир
 
 
 
#19
31.10.2024 15:25:21
Цитата
написал:
это исправление опечаток
Вот теперь всё понятно стало!
Большое Вам спасибо!
 
 
 
#20
01.11.2024 21:12:33
Здравствуйте,

Сейчас обнаружил, что после выполнения процедуры числа с запятыми 123,456789 меняются на 123456789. т.е. запятые удаляются. Если после запятой 2 цифры (123,12) то всё нормально, а если три и больше то запятая теряется.

Как можно исправить?
Код
Sub REPCHAR()Dim T As Double: T = Now
    
    Dim DATA As Variant, LC As Long, R As Long, C As Long
    With ActiveSheet
        LC = .Cells(.Rows.Count, "D").End(xlUp).Row
        DATA = .Range("D1:E" & LC).Value
        For R = LBound(DATA, 1) To UBound(DATA, 1)
            For C = LBound(DATA, 2) To UBound(DATA, 2)
                DATA(R, C) = Replace(DATA(R, C), "A", "А")
                DATA(R, C) = Replace(DATA(R, C), "B", "В")
                DATA(R, C) = Replace(DATA(R, C), "E", "Е")
                DATA(R, C) = Replace(DATA(R, C), "K", "К")
                DATA(R, C) = Replace(DATA(R, C), "M", "М")
                DATA(R, C) = Replace(DATA(R, C), "H", "Н")
                DATA(R, C) = Replace(DATA(R, C), "O", "О")
                DATA(R, C) = Replace(DATA(R, C), "P", "Р")
                DATA(R, C) = Replace(DATA(R, C), "C", "С")
                DATA(R, C) = Replace(DATA(R, C), "X", "Х")
                DATA(R, C) = Replace(DATA(R, C), "T", "Т")
            Next C
        Next R
        .Range("D1:E" & LC).Value = DATA
    End With


MsgBox Now - T
End Sub
 
 
 
#21
01.11.2024 21:18:12
Пожалуйста, прочитайте сообщение #12.  Без тестовых данных нельзя гарантировать работоспособность макроса.
Владимир
 
 
 
#22
01.11.2024 21:33:32
Когда-то, лет 20, назад, писал несколько подобных процедур для корректировки ручного ввода значений в базу данных (ленивым операторам часто лень переключать раскладку и они считают, что если буквы выглядят одинаково, то и нет смысла в лишних "кнопкотычествах")..
Остановился на этих:
Код
Private Sub Repair_RUS()   ' заменить латинские буквы такими же по начертанию русскими
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Application.ScreenUpdating = False: Application.EnableEvents = False
      Dim LATChr$: LATChr = "CcEeTOopPAaHKkXxBM"
      Dim RUSChr$: RUSChr = "СсЕеТОорРАаНКкХхВМ"
      Dim i%
      For i = 1 To Len(LATChr)
         Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Replace _
               What:=Mid(LATChr, i, 1), Replacement:=Mid(RUSChr, i, 1), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
      Next i
   End With
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Private Sub Repair_LAT()   ' заменить русские буквы такими же по начертанию латинскими
   With ActiveSheet.UsedRange
      If Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)) Is Nothing Then Exit Sub
      Application.ScreenUpdating = False: Application.EnableEvents = False
      Dim arrENG: arrENG = Split("C c E e T O o p P A a H K k X x B M")
      Dim arrRUS: arrRUS = Split("С с Е е Т О о р Р А а Н К к Х х В М")
      Dim i%
      For i = 0 To UBound(arrENG)
         Intersect(ActiveWindow.RangeSelection, .SpecialCells(xlCellTypeVisible), .SpecialCells(xlCellTypeConstants)).Replace _
               What:=arrRUS(i), Replacement:=arrENG(i), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
      Next i
   End With
   Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub
Попробуйте.
P.S.Процедуры отличаются способом обработки - стринг или массив. Специально сохранил в "копилке" их обе для примера и сравнения скорости работы.
Изменено: Alex_ST - 01.11.2024 21:37:27
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
 
 
#23
02.11.2024 08:02:47
Цитата
Cristal написал:
Выделил английские слова, запустил макрос, что то не пошло, не произошло изменение английских слов на русскую транскрипцию.
Для того, чтобы визуализировать смесь латиницы и кириллицы у меня также есть простая процедура:
Код
Sub Color_RUS_LAT()   ' Выделяет русские символы в Selection ЗЕЛЁНЫМ, латинские - КРАСНЫМ
   If TypeName(Selection) <> "Range" Then Exit Sub
   With ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).SpecialCells(xlCellTypeVisible)
      If Intersect(Selection, .Cells) Is Nothing Then Exit Sub
      Intersect(Selection, .Cells).Select
   End With
   Dim rCell As Range, i&
   With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With
   For Each rCell In Selection
      For i = 1 To Len(rCell)
         If Mid$(rCell, i, 1) Like "[А-Яа-яЁё]" Then rCell.Characters(i, 1).Font.Color = vbGreen
         If Mid$(rCell, i, 1) Like "[A-Za-z]" Then rCell.Characters(i, 1).Font.Color = vbRed
      Next i
   Next rCell
   With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With
End Sub
На больших диапазонах работает, конечно, не быстро, т.к. обрабатывается не массив, а ячейки по одной.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
 
 
#24
02.11.2024 08:43:57
Alex_ST, Спасибо за другие варианты кода.

Я вспомнил что была такая же ошибка в одном CopyPaste коде. Добавил код перед выгрузкой данных из памяти, для изменения формата чисел.
Код
Sub REPCHAR()Dim T As Double: T = Now
    
    Dim DATA As Variant, LC As Long, R As Long, C As Long
    With ActiveSheet
        LC = .Cells(.Rows.Count, "D").End(xlUp).Row
        DATA = .Range("D1:E" & LC).Value
        For R = LBound(DATA, 1) To UBound(DATA, 1)
            For C = LBound(DATA, 2) To UBound(DATA, 2)
                DATA(R, C) = Replace(DATA(R, C), "A", "А")
                DATA(R, C) = Replace(DATA(R, C), "B", "В")
                DATA(R, C) = Replace(DATA(R, C), "E", "Е")
                DATA(R, C) = Replace(DATA(R, C), "K", "К")
                DATA(R, C) = Replace(DATA(R, C), "M", "М")
                DATA(R, C) = Replace(DATA(R, C), "H", "Н")
                DATA(R, C) = Replace(DATA(R, C), "O", "О")
                DATA(R, C) = Replace(DATA(R, C), "P", "Р")
                DATA(R, C) = Replace(DATA(R, C), "C", "С")
                DATA(R, C) = Replace(DATA(R, C), "X", "Х")
                DATA(R, C) = Replace(DATA(R, C), "T", "Т")
            Next C
        Next R
        .Range("D1").Resize(R).NumberFormat = "@"
        .Range("E1").Resize(R).NumberFormat = "@"
        .Range("D1:E" & LC).Value = DATA
    End With

MsgBox Now - T
End Sub
Изменено: Шерзод Маткаримов - 02.11.2024 08:53:31 (Орфография)
 
 
 
Страницы: 1
Наверх