Пакетная замена в Excel нестандартным методом

Пользователь

Сообщений: 212 Регистрация: 01.01.1970

01.03.2017 10:10:40

Всем доброго дня.
Столкнулся с такой проблемой.
Часто приходится делать массовые замены в Excel файлах больших объемов.
Для этого есть много тем и отличные макросы. которые это грамотно делают,
Сделал и свой макрос, который в т.ч первоначально прописывает пробелы впереди и сзади как в самих данных, так и в таблице соответствия. чтобы менялись только целые слова.
Но все они используют функцию Replace и метод перебора.
если объемы небольшие, этого вполне хватает.
Но бывают так, что сами данные составляют несколько десятков, а то и сотен тысяч строк, да и таблица соответствий - несколько тысяч.
В этом случае замена может занимать более часа времени.

Поэтому вопрос:
Можно ли сделать макрос, который пакетно будет менять данные.
и если можно прошу пример такого макроса.
С уважением.

Прикрепленные файлы

Пакетная замена.xlsm (22.39 КБ)

Изменено: Sobes - 01.03.2017 10:11:55

ZVI

Пользователь

Сообщений: 4433 Регистрация: 23.12.2012

01.03.2017 17:08:53

Добрый день.
Попробуйте такой код для данных на Листе1

Код

Sub Main()
  Dim a(), b, i&, r&, s$
  Dim Rng As Range
  Set Rng = ActiveSheet.Cells(1).CurrentRegion.Columns(1)
  a() = Sheets("Соответствия").Cells(1).CurrentRegion.Columns(1).Resize(, 2).Value
  With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For r = 2 To UBound(a)
      s = Trim(a(r, 1))
      If Len(s) Then .Item(s) = a(r, 2)
    Next
    a() = Rng.Value
    For r = 1 To UBound(a)
      s = Trim(a(r, 1))
      If Len(s) Then
        b = Split(s)
        For i = 0 To UBound(b)
          If .Exists(b(i)) Then b(i) = .Item(b(i))
        Next
        a(r, 1) = Join(b)
      End If
    Next
  End With
  With Rng.Offset(, 1)
    .Value = a()
    .Columns.AutoFit
  End With
End Sub

Sobes Пользователь Сообщений: 212 Регистрация: 01.01.1970	#3 01.03.2017 17:25:12 Спасибо огромное!