Добрый день. Необходимо решить вопрос с поиском и заменой подстрок.
Дано:
На листе 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. Также удалил лишние ||| . Если это проблема сделать сразу, то потом автозаменой смогу это сам убрать.
Добрый день.
Но примеры нужно составлять корректные - там практически нет совпадений, причём лишние пробелы я в коде убиваю тысячей тримов...
В общем код работает корректно на корректных данных (и на 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
Не цитируйте без необходимости [МОДЕРАТОР]
Спасибо преогромное! Запустил макрос - работает. Есть маленький недостаток - если в результате получаются несколько подряд идущих пустых строк(тоесть вообще ни сс в словаре не было), то выдается всего одна. Пример из вложения вроде корректный... Неужели я перепутал английскую и русскую раскладки на букве "с" при его составлении?... Извиняюсь если что за пример. Спасибо за помощь!
Вы на примере из форума пробовали код запускать?
Это чья была идея использовать "cc"? :)
Ну хоть бы "aa" - они хоть на разных клавишах, а лучше кардинально "щщ" :)
По пустым не понял - можно увидеть пример исходный и как нужно? Без кода - он есть в теме, а мои админы всё равно код режут...
Ну вот так мне кажется нагляднее:
На листе 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
По пустым понял - мой код так не сделает, переделывать много, не буду.
Убирайте их вообще вручную фильтром.
Да вы и так помогли. С этим разберусь. Спасибо большое!
После выполнения основного кода, можно просто удалить пустые строки
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
Так ведь хочется по одной оставлять :)
Если бы нужно было удалить все пустые - можно просто в мой код добавить ещё один пустой аналогичный массив и собирать данные в него, увеличивая индекс, если есть что собирать.
А в финале им просто затереть исходные данные.
Я решил не редактировать ваш макрос, поэтому написал 2 дополнительных макроса, которые можно вызывать самостоятельно.
Один чистит все, а второй(DeleteEmptyRow2) по одной строке оставляет и считает сколько удалил смежных строк ::)