Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

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

Автор Тема: Поиск словосочетаний по словарю и замена найденных в ячейке  (Прочитано 385 раз)

0 Пользователей и 1 Гость просматривают эту тему.

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

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

На листе 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
Записан

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

Сделал пример. Во вложении. Результат на Листе 3. Также удалил лишние ||| . Если это проблема сделать сразу, то потом автозаменой смогу это сам убрать.
« Последнее редактирование: 07.12.2017, 16:07:32 от vikttur »
Записан

Hugo121

  • Постоялец
  • ***
  • Уважение: +43/-0
  • Оффлайн Оффлайн
  • Сообщений: 296

Добрый день.
Но примеры нужно составлять корректные - там практически нет совпадений, причём лишние пробелы я в коде убиваю тысячей тримов...
В общем код работает корректно на корректных данных (и на 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 R41892628200

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

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

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

Hugo121

  • Постоялец
  • ***
  • Уважение: +43/-0
  • Оффлайн Оффлайн
  • Сообщений: 296

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

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

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

На листе 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

  • Постоялец
  • ***
  • Уважение: +43/-0
  • Оффлайн Оффлайн
  • Сообщений: 296

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

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

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 5

Да вы и так помогли. С этим разберусь. Спасибо большое!
« Последнее редактирование: 08.12.2017, 15:17:48 от vikttur »
Записан

boa

  • Глобальный модератор
  • Постоялец
  • *****
  • Уважение: +26/-0
  • Оффлайн Оффлайн
  • Сообщений: 481
  • Доброта спасет мир...

После выполнения основного кода, можно просто удалить пустые строки
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
« Последнее редактирование: 26.12.2017, 23:52:41 от boa »
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Hugo121

  • Постоялец
  • ***
  • Уважение: +43/-0
  • Оффлайн Оффлайн
  • Сообщений: 296

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

boa

  • Глобальный модератор
  • Постоялец
  • *****
  • Уважение: +26/-0
  • Оффлайн Оффлайн
  • Сообщений: 481
  • Доброта спасет мир...

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



Темы без ответов

22.05.2018 11:38 Скрипт написать который допишет данные в файл 171
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 597
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 567
23.01.2018 13:46 Найти вероятность повторной покупки 578
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 780
06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 846
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 1081
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 2530
15.03.2017 15:45 автозамена картинок PowerPoint 1567
11.03.2017 13:43 Изменить нумерацию страниц 1802





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.118 секунд. Запросов: 104.