Страницы: 1
RSS
Заменить все символы на "-" (дефис) кроме букв и цифр, макрос для замены всевозможных символов, кроме букв и цифр, на дефис
 
Здравствуйте, не подскажете как создать макрос для замены всевозможных символов (включая пробелы), кроме латинских букв и цифр, на дефис?
И еще нужно заменить два или несколько дефисов подряд на один (т.е. если текст при замене на дефисы станет таким - "planeta--excel---xlsm", то заменить его на "planeta-excel-xlsm"  ;)  

В этом деле я вообще не бум-бум  :(  (
Нашла макрос, который удаляет все символы кроме нужных, но оказалось не совсем то.... Лучше заменять. (так как в кодах VBA не разбираюсь, не получилось изменить готовый макрос)

Макрос такой:
Код
Sub RemoveDigits()

        Dim vRange As Range, vCell As Range
        Dim vStr As Integer, rangeLastCol As Integer, rangeLastRow As Integer, tempLastRow As Integer, i As Integer
        Dim str_all As String, x As String, y As String, v As String, w As String
        rangeLastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To rangeLastCol
            tempLastRow = Cells(Rows.Count, i).End(xlUp).Row
            If rangeLastRow < tempLastRow Then
                rangeLastRow = tempLastRow
            End If
        Next i
        Set vRange = ThisWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(rangeLastRow, rangeLastCol))
        str_all = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-"
        For Each vCell In vRange
            For vStr = 1 To Len(vCell)
                x = vCell.Value
                y = Mid(x, vStr, 1)
                If InStr(1, str_all, y) > 0 Then
                    v = y
                    y = ""
                Else
                    v = ""
                    y = ""
                End If
                w = w & v
            Next vStr
            vCell.Value = w
            x = ""
            y = ""
            v = ""
            w = ""
        Next vCell
    End Sub 
Заранее все спасибо за помощь!
 
Не уверен что 100% выполненая задачка, но эт моя очередная попытка переделать удфку ikki
Лень двигатель прогресса, доказано!!!
 
После такого свое вообще выкладывать стыдно :-)

Но я все таки выложу, тем более, что я попытался сделать ее универсальной
Код
Function ЛАТИНИЦА_И_ЦИФРЫ$(Ячейка As Range, Optional Замена$ = "-", Optional Удалять_дубли As Boolean = True)
    Dim rplcS$, rplcS2$, inpS$, i, outS$
    
    rplcS = IIf(Замена <> "", Left(Замена, 1), "")
    inpS = Ячейка.Text
    outS = ""
    
    For i = 1 To Len(inpS)
        If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789", Mid(inpS, i, 1)) = 0 Then
            outS = outS & rplcS
        Else
            outS = outS & Mid(inpS, i, 1)
        End If
    Next i
    
    If Удалять_дубли And rplcS <> "" Then
        rplcS2 = rplcS & rplcS
        Do While InStr(outS, rplcS2) > 0
            outS = Replace(outS, rplcS2, rplcS)
        Loop
    End If
    ЛАТИНИЦА_И_ЦИФРЫ = outS
End Function
 
Учимся сами и помогаем другим...
 
Цитата
ber$erk пишет: После такого свое вообще выкладывать стыдно
ber$erk, я ваще плагиатом занимаюсь методом научного тыка, вы в отличии от меня понимаете что у вас там написано    :)
Изменено: Сергей - 14.01.2015 10:42:45
Лень двигатель прогресса, доказано!!!
 
:oops:  :D
Учимся сами и помогаем другим...
 
Доброе время суток
И как это без регулярок обошлось?

Код
Public Function LatinAndDigit(ByVal this As String) As String
    Dim pReg As Object
    If pReg Is Nothing Then
        Set pReg = CreateObject("VBScript.RegExp")
        pReg.IgnoreCase = True: pReg.Global = True
    End If
    pReg.Pattern = "[^A-Z0-9]"
    this = pReg.Replace(this, "-")
    pReg.Pattern = "-{2,}|^-+|$-+"
    LatinAndDigit = pReg.Replace(this, "")
End Function
 
 
Андрей VG, не обошлось во втором сообщении такая
Код
Function ikki$(s$)
    Static r As Object: If r Is Nothing Then Set r = CreateObject("vbscript.regexp"):
    r.Global = 1:
    r.Pattern = "[А-яа-я-\s]+"
    ikki = r.Replace(s, "-")
End Function 
Лень двигатель прогресса, доказано!!!
 
Сергей, извиняюсь, ваш файл не смотрел.
Хотя ваш Pattern

Код
 "[А-яа-я-\s]+"
'не обработал строку "   this    is 3422%!!%322  "
Да и у меня ляп есть. Лучше

Код
    pReg.Pattern = "[^A-Z0-9]+"
    this = pReg.Replace(this, "-")
    pReg.Pattern = "^-|-$"
    LatinAndDigit = pReg.Replace(this, "")
 
с учётом вашего предложения;)
 
Спасибо всем за ответы!
Но я немного запуталась...
Беру макрос вставляю в VBA, потом на листе пишу примеры, хочу применить макрос, но в списке макросов пусто :(

Пробовала вставить код как модуль, и пробовала добавить на листе (2 раза нажав на лист в инспекторе объектов в VBA)
Я что-то путаю или как? Тот что я выложила, добавляла как модуль и он работал.
 
пробовала варианты из сообщений #3 и #6
 
господа, на ваших идеях - вот так получилось... вроде то, что надо
Код
Function ikki$(s$)
    Static r As Object: If r Is Nothing Then Set r = CreateObject("vbscript.regexp"):
    r.Global = 1: r.IgnoreCase = True
    r.Pattern = "[^А-ЯA-Z0-9]+"
    ikki = r.Replace(s, "-")
End Function
Цитата
miadiva1 пишет: Беру макрос вставляю в VBA, потом на листе пишу примеры, хочу применить макрос, но в списке макросов пусто... пробовала варианты из сообщений #3 и #6
Посмотрите на примере #2 - как применять UDF (user-defined-function)... даже в приёмы заглянуть будет не лишним - почитать про Пользовательские функции

p.s. если хотите использовать как макрос - используйте ещё один добрый совет от ikki (пост#15):
Код
 Sub t(): For Each s In [b1:b2].Cells: s.Value = ikki(s.Value): Next: End Sub

(диапазон укажите нужный) - можно примерно так
Код
 Sub t(): For Each s In [a1:a2].Cells: s.Offset(0, 3).Value = ikki(s.Value): Next: End Sub
Изменено: JeyCi - 14.01.2015 11:13:16
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
miadiva1, Вам предлагают пользовательскую функцию. Вводите её как обычную формулу с передачей параметра, после того, как добавили в модуль книги.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Кстати, паттерн [А-Я] не захватывает букву Ё, так как её код больше, чем у Я (тадаммм).
Поэтому
Код
Function ikki$(s$)
    Static r As Object: If r Is Nothing Then Set r = CreateObject("vbscript.regexp"):
    r.Global = 1: r.IgnoreCase = True
    r.Pattern = "[^А-ЯЁA-Z0-9]+"
    ikki = r.Replace(s, "-")
End Function
F1 творит чудеса
 
Цитата
Максим Зеленский пишет: не захватывает букву Ё... Поэтому...
спасибо  8)
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
Огромное спасибо! Все отлично работает!
 
И еще 1 вопрос возник, возможно ли объединить данный макрос с макросом транслитерации кириллицы?

Код
Function Translit(ByVal txt As String) As String
    iRussian$ = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    iTranslit = Array("", "a", "b", "v", "g", "d", "e", "jo", "zh", "z", "i", "jj", "k", _
                      "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "h", "c", "ch", _
                      "sh", "zch", "''", "'y", "'", "eh", "ju", "ja")
    For iCount% = 1 To 33
        txt = Replace(txt, Mid(iRussian$, iCount%, 1), iTranslit(iCount%), , , vbTextCompare)
    Next
    Translit$ = txt
End Function
 

Сейчас их отдельно использую, но вот если объединить, вообще было бы замечательно :)
 
в ячейке напишите =Translit(ikki())
хотя совсем не понятно совмещение когда у вас была просьба русские буквы удалить
Изменено: Сергей - 14.01.2015 12:31:12 (посмотрел последние УДФки они русские буквы оставляют извиняйте изначально я их удалял)
Лень двигатель прогресса, доказано!!!
 
Цитата
Сергей пишет: всевозможных символов (включая пробелы), кроме латинских букв и цифр
Изменено: Сергей - 14.01.2015 12:32:58 (эт ни я пишу)
Лень двигатель прогресса, доказано!!!
 
а, классно! Так просто :)
Теперь все. Благодарю всех за помощь!
 
Ой, они у меня конфликтуют (((
Ошибку выводит :(
 
покажите на примере в файле до 100 кб
Лень двигатель прогресса, доказано!!!
 
?
Лень двигатель прогресса, доказано!!!
 
А, все ок. Это я, кажется, глюкнула. :(
Страницы: 1
Наверх