Помогите заменить символ

[izhrvd]

Есть телефонная база, надо заменить первую 8-ку на цифру 7. Не могу сам сделать макрос.

Дело в том , что баз несколько. Поэтому проще макрос подсказать(если конечно есть). Функциями не получается, т.к. надо потом делать импорт в другую прогу.

к примеру вот(в файле)

[EducatedFool]

Вот весь код:

Sub Replace8()
    On Error Resume Next
    Dim cell As Range: Application.ScreenUpdating = False
    For Each cell In Intersect(ActiveSheet.UsedRange, Selection)
        If Left(cell, 1) = "8" Then cell = "7" & Mid(cell, 2)
    Next cell
End Sub

Private Sub Workbook_Open()
    Application.OnKey "^r", "Replace8"
End Sub

Запустите прикреплённый к сообщению файл (или подключите его как надстройку)

Потом в любом из своих файлов выделите диапазон с номерами (можно выделять столбцы целиком), и нажмите Ctrl + R

[izhrvd]

Огромное спасибо, все работает!

[izhrvd]

Добрый день. Опять появилась трудно решаемая для меня задача.
Необходим макрос: имеем два столбца с номерами телефонов. Нужно сравнить их так что бы из второго столбца удолились те номера которые присутствуют в первом.
Буду очень признателен.

[EducatedFool]

Необходим макрос

Необходим файл

что бы из второго столбца удолились те номера которые присутствуют в первом.

На месте удалённых номеров оставлять пустые ячейки, или удалять номера вместе с ячейками?


Чем не устраивают формулы?
В соседний столбец пишем формулу

  Ячейка: C1      Формула  (стиль A1):   =ЕСЛИ(СЧЁТЕСЛИ(A:A;B1)=0;"";B1)
                  Формула  (стиль R1C1): =ЕСЛИ(СЧЁТЕСЛИ(C[-2];RC[-1])=0;"";RC[-1])

и растягиваем её на нужное количество строк.

[izhrvd]

Так пойдет.

[izhrvd]

удалять номера вместе с ячейками
1 или 2 формула?

[EducatedFool]

Вот макрос:

Sub test()
    Dim cell As Range, ra As Range: Application.ScreenUpdating = False
    For Each cell In Range([b1], Range("b" & Rows.Count).End(xlUp)).Cells
        If WorksheetFunction.CountIf([a:a], cell) Then
            If ra Is Nothing Then Set ra = cell Else Set ra = Union(ra, cell)
        End If
    Next cell
    On Error Resume Next: ra.Delete
    [b:b].SpecialCells(xlCellTypeBlanks).Delete
End Sub

[izhrvd]

Огромное спасибо!!!!!!!!!!!!!!
Все отлично работает!!!!!!!!!