Microsoft Excel:
  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню Заметки | Создание собственного списка автозамены

Rambler's Top100


Counter CO.KZ
Если Вам необходимо, сразу после ввода текста, автоматически исправлять наиболее часто встречающиеся ошибки, например, поменять exel на excel, или же, облегчить себе ввод некого текста, например, сделать так, чтобы после ввода с1 (сотрудник1) в ячейке появилось ФИО соответствующего сотрудника, то для этого можно воспользоваться стандартной АвтоЗаменой, однако, такая замена будет применяться ко всем ячейкам, если же нужно ограничиться только опредёленной рабочей книгой, более того, листы и диапазоны, в которых нужно применять автозамену, могут меняться и Вам необходимо иметь возможность их корректировать, то можно создать свой собственный список замены и диапазонов (см. скриншот)

Для этого, откройте нужную рабочую книгу, добавьте новый рабочий лист, присвойте ему имя "Замена" и определите диапазон в котором будет перечислены листы и диапазоны, в примере, это [B3:C12] (столбец B предназначен для имён листов, а столбец C для адресов) и диапазон, содержащий список автозамены, в примере, он начинается с ячейки [B15] (столбец B содержит перечень текста, подлежащего замене, а столбец C должен содержать текст, на который нужно заменить текст из столбца B)

Теперь, заполните собственный список автозамены.



Затем, добавьте в модуль книги ThisWorkbook(ЭтаКнига) следующее событие : 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
    Dim iSource As Range, iDiapazon As Range, iRow&, iText$, iAddress 'As Variant

    With ThisWorkbook.Worksheets("Замена") 'Me.Worksheets("Замена")
         iAddress = Application.VLookup(Sh.Name, .[B3:C12], 2, 0)
         If Not IsError(iAddress) Then
            Set iSource = Intersect(Target, Sh.Range(iAddress))
            If Not iSource Is Nothing Then
               Set iDiapazon = .Range(.[B15], .[B65536].End(xlUp))
               Application.EnableEvents = False
               'Application.ScreenUpdating = False
               For iRow = 1 To iDiapazon.Count 'iDiapazon.Rows.Count
                   iText = iDiapazon(iRow, 1)
                   If Not iSource.Find(iText, , xlFormulas) Is Nothing Then
                      iSource.Replace iText, iDiapazon(iRow, 2), xlPart
                   End If
               Next
               'Application.ScreenUpdating = True
               Application.EnableEvents = True
            End If
         End If
    End With
End Sub
А в модуль рабочего листа Замена скопируйте событие Worksheet_BeforeDoubleClick, затем сохраните изменения, и когда Вам понадобится внести имя листа и адрес диапазона, просто кликните дважды любую ячейку диапазона [B3:C12] и с помощью диалогового окна выделите нужный диапазон и кликните кнопку Ok. 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
    If Not Intersect(Target, [B3:C12]) Is Nothing Then
       On Error Resume Next
       Dim iSource As Range
       Set iSource = Application.InputBox("Выберите диапазон", "", Type:=8)
       If Not iSource Is Nothing Then
          If Not iSource.Parent Is ActiveSheet Then
             '[B:C].Rows(Target.Row).Value = Array( _
             iSource.Parent.Name, iSource.Address(False, False))
             
             With Intersect(Target.EntireRow, [B:C])
                  .NumberFormat = "@"
                  .Value = Array(iSource.Parent.Name, iSource.Address(False, False))
             End With
          End If
       End If
       Cancel = True
    End If
End Sub




Автор : Климов Павел Юрьевич
© 2004-2016 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff