Новости:

Прикрепить к сообщению можно только файлы xls, gif, jpg, rar, zip,7z, bas, frm, cls, doc размером до 150 Кб.

Главное меню

Поиск словосочетаний по словарю и замена найденных в ячейке

Автор Александр Кучинский, 07.12.2017, 15:44

« назад - далее »

Александр Кучинский

Добрый день. Необходимо решить вопрос с поиском и заменой подстрок.
Дано:

На листе 1 в столбце А перечислены словосочетания таким образом:
сс1 | cc2 | cc3 | cc4
сс2 | cc6 | cc3 | cc8
сс5 | cc6 | cc7 | cc4 | cc9 | cc10
cc12 | cc13

На листе 2 в двух столбцах содержится словарь замен:
столбец А  ; столбец В
сс1 ;  новый сс1
сс2 ;  новый сс2
сс3 ; 
сс4 ;  новый сс4
сс5 ;  новый сс5
сс6 ; 
сс7 ;  новый сс7
сс8 ;  новый сс8
сс9 ; 
сс10 ;  новый сс10
сс11 ;  новый сс11
сс12 ;  новый сс12
сс13 ;  новый сс13

Нужно поменять встречающуюся подстроку в Лист1:СтолбецА, новым соответствующим значением из Лист2:СтолбецВ

Для указанного примера это будет так:
новый сс1 | новый cc2 | | новый cc4
новый сс2 | | | новый  cc8
новый сс5 | | новый cc7 | новый cc4 | | новый cc10
новый cc12 | новый cc13

Александр Кучинский

Сделал пример. Во вложении. Результат на Листе 3. Также удалил лишние ||| . Если это проблема сделать сразу, то потом автозаменой смогу это сам убрать.

Hugo121

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

Option Explicit

Sub tt()
    Dim a, i&, b, el

    With CreateObject("Scripting.Dictionary")
        a = Sheets(2).[a1].CurrentRegion.Value
        For i = 1 To UBound(a): .Item(Trim(a(i, 1))) = Trim(a(i, 2)): Next
        a = Sheets(1).[a1].CurrentRegion.Value
        For i = 1 To UBound(a)
            b = Split(a(i, 1), "|"): a(i, 1) = Empty
            For Each el In b
                If Len(.Item(Trim(el))) Then a(i, 1) = a(i, 1) & " | " & .Item(Trim(el))
            Next
            a(i, 1) = Mid(a(i, 1), 4)
        Next
    End With
    Sheets(1).[a1].CurrentRegion.Value = a
End Sub
webmoney: E265281470651 Z422237915069

Александр Кучинский

Не цитируйте без необходимости [МОДЕРАТОР]

Спасибо преогромное! Запустил макрос - работает. Есть маленький недостаток - если в результате получаются несколько подряд идущих пустых строк(тоесть вообще ни сс в словаре не было), то выдается всего одна. Пример из вложения вроде корректный... Неужели я перепутал английскую и русскую раскладки на букве "с" при его составлении?... Извиняюсь если что за пример. Спасибо за помощь!

Hugo121

Вы на примере из форума пробовали код запускать?
Это чья была идея использовать "cc"? :)
Ну хоть бы "aa" - они хоть на разных клавишах, а лучше кардинально "щщ" :)
По пустым не понял - можно увидеть пример исходный и как нужно? Без кода - он есть в теме, а мои админы всё равно код режут...
webmoney: E265281470651 Z422237915069

Александр Кучинский

Ну вот так мне кажется нагляднее:

На листе 1 в столбце А перечислены словосочетания таким образом:
сс1 | cc2 | cc3 | cc4
сс2 | cc6 | cc3 | cc8 - ни одного нет в алфавите 1-я строка
сс2 | cc6 | cc3 | cc8 | сс9 - ни одного нет в алфавите 2-я строка
сс5 | cc6 | cc7 | cc4 | cc9 | cc10
cc12 | cc13

На листе 2 в двух столбцах содержится словарь замен:
столбец А  ; столбец В
сс1 ;  новый сс1
сс2 ; 
сс3 ;
сс4 ;  новый сс4
сс5 ;  новый сс5
сс6 ;
сс7 ;  новый сс7
сс8 ; 
сс9 ;
сс10 ;  новый сс10
сс11 ;  новый сс11
сс12 ;  новый сс12
сс13 ;  новый сс13

Нужно поменять встречающуюся подстроку в Лист1:СтолбецА, новым соответствующим значением из Лист2:СтолбецВ

Для указанного примера это будет так:
новый сс1 | новый cc2 | | новый cc4
!!!!  Одна строка пустая, а второй нету !!!!
новый сс5 | | новый cc7 | новый cc4 | | новый cc10
новый cc12 | новый cc13

Hugo121

По пустым понял - мой код так не сделает, переделывать много, не буду.
Убирайте их вообще вручную фильтром.
webmoney: E265281470651 Z422237915069

Александр Кучинский

Да вы и так помогли. С этим разберусь. Спасибо большое!

boa

После выполнения основного кода, можно просто удалить пустые строки

Option Explicit

Sub DeleteEmptyRow1()
'просто удалит пустые строки
With ActiveSheet
    Dim l&, i&
    l = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = l To 1 Step -1
        If Application.WorksheetFunction.CountA(.Rows(i)) = 0 Then .Rows(i).Delete
    Next
End With
End Sub

Sub DeleteEmptyRow2()
'подсчитает сколько удалил подряд пустых строк и запишет это
With ActiveSheet
    Dim l&, i&, j&
    j = 1
    l = .Cells(.Rows.Count, 1).End(xlUp).Row
    For i = l To 1 Step -1
        If Application.WorksheetFunction.CountA(.Rows(i)) = 0 Then
            If i > 1 Then   'что бы не выпасть в ошибку на 1-й строке
                If Application.WorksheetFunction.CountA(.Rows(i - 1)) = 0 Then
                    j = j + 1
                    .Rows(i).Delete
                Else
                    .Cells(i, 1).Value = "Здесь было " & j & " пустых строк"
                    j = 1
                End If
            End If
        End If
    Next
End With
End Sub
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Hugo121

Так ведь хочется по одной оставлять :)
Если бы нужно было удалить все пустые - можно просто в мой код добавить ещё один пустой аналогичный массив и собирать данные в него, увеличивая индекс, если есть что собирать.
А в финале им просто затереть исходные данные.
webmoney: E265281470651 Z422237915069

boa

Я решил не редактировать ваш макрос, поэтому написал 2 дополнительных макроса, которые можно вызывать самостоятельно.
Один чистит все, а второй(DeleteEmptyRow2) по одной строке оставляет и считает сколько удалил смежных строк ::)
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра