Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | Range (Cells)


Rambler's Top100


Counter CO.KZ


    [1] [2] [3] [4] [5] [6]

  1. Как заполнить поле со списком уникальными значениями, которые будут вводится в ячейки нужного диапазона ? 14.06.2007
  2. Как используя словарь получить список уникальных, т.е. неповторяющихся значений нужного диапазона ? 30.06.2007
  3. Как в нужном диапазоне удалить все повторы определённого значения ? 26.08.2008
  4. Как программно ввести в ячейку m³ ? 22.06.2007
  5. Как программно отобразить диалоговое окно Мастер функций для ввода или редактирования формулы в нужной ячейке ? 22.07.2007
  6. Как изменить цвет заливки каждой n-ой строки указанного диапазона ? 22.06.2007
  7. Как выделить (т.е. изменить цвет заливки) все ячейки, данные которых, не соответствуют условиям проверки вводимых данных ? 22.09.2007
  8. Как создать всплывающие подсказки для нужных ячеек ? 03.07.2007
  9. Как одновременно (синхронно) изменять данные и параметры форматирования сразу в нескольких рабочих листах ? 22.07.2007
  10. Как синхронно изменять данные (значения, формулы) сразу в нескольких рабочих листах, в т.ч. и скрытых ? 22.07.2007
  11. Как после изменения данных, сделать Прописной первую букву каждого слова, преобразовав все остальные в строчные (за исключением ячеек с формулами) ? 08.08.2011
  12. Как после двойного клика в ячейке любого рабочего листа - об'единить данные, которые расположены в аналогичных ячейках всех рабочих листов, а затем заполнить эти ячейки полученной строкой ? 30.09.2007
  13. Как после выделения диапазона подсчитать ширину всех выделенных столбцов и отобразить полученное значение в строке состояния ? 23.03.2009
  14. Как после активации ячейки/диапазона "выделить" этот об'ект, причём, без изменения параметров форматирования ? 29.03.2009
  15. Как в нужном диапазоне программно удалить все буквы латиницы или кириллицы ? 25.09.2007
  16. Как подсчитать во всех рабочих листах активной рабочей книги, количество цифр, а также букв латиницы и кириллицы ? 21.06.2014
  17. Как определить содержит ли ячейка текст ? 11.07.2008
  18. Как определить есть ли нужный текст в ячейке ? 24.01.2011
    [1] [2] [3] [4] [5] [6]

  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    Для того, чтобы после ввода данных в ячейки столбца "A", Вы могли заполнить, предварительно созданный элемент управления поле со списком, уникальными, т.е. неповторяющимися значениями (исключением здесь является значение Пусто и пустая строка ""), достаточно скопировать весь нижеприведённый код в модуль нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iTarget As Range, iCell As Range
        Set iTarget = Intersect(Target, [A:A])
        If Not iTarget Is Nothing Then
           With Me.DropDowns(1)
                For Each iCell In iTarget
                    If Application.CountBlank(iCell) = 0 Then
                       iText$ = CStr(iCell)
                       If IsError(Application.Match( _
                       iText$, .List, 0)) Then .AddItem Left(iText$, 255)
                    End If
                Next
           End With
        End If
    End Sub
    или
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iTarget As Range, iCell As Range
        Set iTarget = Intersect(Target, [A:A])
        If iTarget Is Nothing Then Exit Sub
        
        With Me.DropDowns(1)
             For Each iCell In iTarget
                 iText$ = CStr(iCell)
                 If Len(iText$) > 0 Then
                    If IsError(Application.Match( _
                    iText$, .List, 0)) Then .AddItem Left(iText$, 255)
                 End If
             Next
        End With
    End Sub
    В этом примере используется элемент управления Поле со списком с панели инструментов Формы.

    Примечание : Используемый элемент управления DropDown не позволяет добавлять данные, содержащие более 255 символов, поэтому, уникальность вводимого текста определяется только по первым 255 символам.

    Комментарий :
  • При необходимости можно запретить изменение данных более чем в одной ячейке [FAQ208] или установить свою квоту на количество изменяемых ячеек.
  • Удаления данных в указанном столбце не приводит к удалению аналогичных элементов списка.
  • Закрытие рабочей книги не приводит к очистке и удалению списка.
  • Ответ :

    Для того, чтобы определить встречается ли в указанном диапазоне определённый текст более одного раза, и в случае положительного ответа - удалить все повторы этого текста, достаточно использовать нижеприведённый код :
  • Private Sub DeleteRepeat()
        With Application
             Dim iSource As Range
             Set iSource = .ThisWorkbook.Worksheets(1).[D4:D549]
             'Укажите нужную рабочую книгу и рабочий лист,
             'а также диапазон смежных ячеек
             iText$ = "Искомый_текст"
             iCount& = .CountIf(iSource, iText$)
             Select Case iCount&
                Case 0: MsgBox "Искомое значение не найдено", , ""
                Case 1: MsgBox "В указанном диапазоне нет повторов", , ""
                Case Else
                .ScreenUpdating = False
                .Calculation = xlManual
                For iCounter& = 1 To iCount& - 1
                    iSource.Find( _
                    iText$, , xlValues, xlWhole, , xlPrevious).ClearContents
                Next
                .Calculation = xlAutomatic
                .ScreenUpdating = True
            End Select
        End With
    End Sub
    Если же определение наличия/повторения данных необязательно, то :
    Private Sub DeleteRepeat()
        iText$ = "Искомый_текст"
        Dim iSource As Range
        Set iSource = ThisWorkbook.Worksheets(1).Range("D4:D549")
        With Application
             .ScreenUpdating = False
             .Calculation = xlManual
             For iCounter& = 1 To .CountIf(iSource, iText$) - 1
                 iSource.Find( _
                 iText$, , xlValues, xlWhole, , xlPrevious).ClearContents
             Next
             .Calculation = xlAutomatic
             .ScreenUpdating = True
        End With
    End Sub
    Совет : Для получения списка, содержащего только уникальные значения, проще воспользоваться расширенным фильтром или другими примерами, которые можно найти на этом сайте.
  • Ответ : Скачать пример

    Для того, чтобы изменить цвет заливки каждой n-ой строки указанного диапазона, для примера, пусть это будет каждая вторая строка, достаточно использовать нижеприведённый код.
  • Private Sub ZebraRange()
        With ThisWorkbook.Worksheets(1).[A5:H300]
             If .Parent.ProtectContents = True Then
                MsgBox "Изменить цвет заливки никак не можно, хотя ...", , ""
                Exit Sub
             End If
             .Application.ScreenUpdating = False
             .EntireRow.Hidden = False
             .MergeCells = False '.UnMerge
             .Interior.ColorIndex = xlColorIndexNone
             For iRow& = 1 To .Rows.Count Step 2
                 .Rows(iRow&).Interior.Color = vbBlack
             Next
             .Application.ScreenUpdating = True
        End With
    End Sub
    Private Sub ZebraRows()
        With ThisWorkbook.Worksheets(1).Rows("5:300")
             If .Worksheet.ProtectContents = True Then
                MsgBox "Изменить цвет заливки никак не можно, хотя ...", , ""
                Exit Sub
             End If
             .Application.ScreenUpdating = False
             .Hidden = False
             .UnMerge '.MergeCells = False
             .Interior.ColorIndex = xlColorIndexNone
             For iRow& = 1 To .Rows.Count Step 2
                 .Rows(iRow&).Interior.ColorIndex = 1
             Next
             .Application.ScreenUpdating = True
        End With
    End Sub
    Комментарий : Отображение всех строк и снятие об'единения ячеек не носит обязательного характера, но имеет смысл в случае наличия скрытых строк и об'единённых ячеек. Предварительное же удаление заливки, позволяет почти всегда получить ожидаемый результат, даже в случае наличия заливки в указанном диапазоне. Исключением является присутствие условного форматирования и/или наличие пользовательского цвета, созданного на основании выбранного цвета. Впрочем, при необходимости, их также можно удалить (см. пример)

    Если же Вы уверены, что все вышеперечисленные нюансы(препоны) отсутствуют, то далее опубликован вариант, который позволяет изменить цвет заливки каждой чётной и нечётной строки выделенного диапазона.
    Private Sub ZebraSelectionEven()
        Application.ScreenUpdating = False
        Dim iRow As Range
        For Each iRow In Selection.Rows
            If iRow.Row Mod 2 = 0 Then iRow.Interior.Color = vbYellow
        Next
        Application.ScreenUpdating = True
    End Sub
    Private Sub ZebraSelectionOdd()
        Application.ScreenUpdating = False
        Dim iRow As Range
        For Each iRow In Selection.Rows
            If iRow.Row Mod 2 = 1 Then iRow.Interior.ColorIndex = 6
        Next
        Application.ScreenUpdating = True
    End Sub

  • Ответ : Актуально для MS Excel 97, 2000, XP

    Если Вы, для проверки вводимых данных, используете описанную здесь возможность, то знаете, что обойти наложенные ограничения довольно просто. Т.к. эта проверка предназначена только для проверки данных вводимых непосредственно с клавиатуры, то она не будет действовать, если данные являются результатом вычислений формул, если эти данные были скопированы или изменены программного, в т.ч. и с использованием VBA. Поэтому, почти всегда существует вероятность появления, так называемых, неправильных ячеек, т.е. ячеек данные которых не соответствуют наложенным условиям проверки. Но если "неправильные" ячейки всё-таки появились, то существует способ, который позволяет выявить такие ячейки, причём без использования макросов. Впрочем, если он Вас не устраивает, то нижеопубликованный макрос также позволяет определить наличие в активном рабочем листе таких ячеек и изменить цвет их заливки.
  • Private Sub SelectAll_InCorrectValidation()
        If TypeName(ActiveSheet) <> "Worksheet" Then
           MsgBox "Необходим рабочий лист", vbExclamation, ""
           Exit Sub
        End If
        If ActiveSheet.ProtectContents = True Then
           MsgBox "Снимите защиту листа", vbExclamation, ""
           Exit Sub
        End If
        On Error Resume Next
        Dim iValidation As Range, iCell As Range
        Set iValidation = ActiveSheet.Range("A1").SpecialCells(xlCellTypeAllValidation)
        If Not iValidation Is Nothing Then
           Application.ScreenUpdating = False
           For Each iCell In iValidation
               If Not iCell.Validation.Value Then _
               iCell.Interior.ColorIndex = 3 '.Color = vbRed
           Next
           Application.ScreenUpdating = True
        End If
    End Sub
    Если же Вам необходимо произвести поиск таких ячеек - во всех рабочих листах указанной книги (в нижеопубликованном примере это рабочая книга) и составить отчёт о найденных ячейках, например, в виде текстового файла, то используйте следующий макрос.
    Private Sub CreateReport_InCorrectValidation()
        On Error Resume Next

        Dim iBook As Workbook, iList As Worksheet
        Dim iSource As Range, iCell As Range, iFileName$

        Set iBook = ActiveWorkbook 'ThisWorkbook

        iFileName = iBook.Path & "\ErrorValidationCell.txt"
        Open iFileName For Output As #1

        For Each iList In iBook.Worksheets
            If Not iList.ProtectContents Then
               Set iSource = iList.UsedRange.SpecialCells(xlCellTypeAllValidation)
               If Not iSource Is Nothing Then
                  For Each iCell In iSource
                      If Not iCell.Validation Then _
                      Print #1, iCell.Address(False, False, , True)
                  Next
               End If
               Set iSource = Nothing
            Else
               Print #1, "Ячейки рабочего листа " & _
               iList.Name & " не проверялись, т.к. лист защищён"
            End If
        Next

        Close #1: iBook.FollowHyperlink iFileName 'необязательно
    End Sub

  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    Для того, чтобы после выделения нужных ячеек, на экране появились необходимые подсказки к этим ячейкам, можно сделать следующее :

    1. Создать нужные подсказки, используя для этого графические об'екты, например, Rectangles (Прямоугольник), Ovals (Овал), Textboxes (Надпись), Pictures (Рисунок)
    2. Изменить имена этих об'ектов так, чтобы имя подсказки совпадало с адресом ячейки, при активации которой, должна появиться эта подсказка.
    3. Cкопировать нижеприведённый код, изменённый в соответствии со своими требованиями, в модуль нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        If Me.Pictures.Count = 0 Then Exit Sub
           Me.Pictures.Visible = False '''
           iAddress$ = ActiveCell.Address
           Select Case iAddress$
               Case "$B$10", "$I$11", "$I$17"
               Me.Pictures.ShapeRange(iAddress$).Visible = True
           End Select
    End Sub
    Примечание :
  • В этом примере, в качестве всплывающих подсказок, используются рисунки, созданные с помощью этого совета.
  • Семейство Pictures содержит не только рисунки, но и OLEObjects в т.ч. Active-X элементы управления.
  • Вы можете использовать графические об'екты различных семейств, но в этом случае, семейство Pictures и т.п. необходимо заменить на DrawingObjects.
  • Скрытие графических об'ектов приводит к очистке буфера обмена
    (неактуально для MS Excel 2000, XP по причине появления в них собственного буфера обмена) и невозможности отмены последних выполненных команд.
  • Если существует вероятность переименования/удаления подсказки, то перед отображением имеет смысл проверить наличие об'екта с этим именем.

    Комментарий : Аналогичную задачу можно решить и без использования макросов, причём, если Вас в принципе устраивают примечания, но хочется немного разнообразить их внешний вид, то можно воспользоваться этим советом.

    [ Как создать всплывающую подсказку к ячейке ? ]
    [ Как создать всплывающее изображение, при наведении курсора мышки на ячейку ? ]
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Для того, чтобы синхронно изменять данные сразу в нескольких рабочих листах, достаточно всего лишь вручную выделить(сгруппировать) нужные листы [FAQ]
    Это позволит Вам обойтись без использовании макросов, однако, при наличии нескольких групп и частом их применении, выделение листов можно осуществить и программно. Для этого, скопируйте нижеприведённый код в модуль ThisWorkbook(ЭтаКнига) нужной рабочей книги и сохраните внесённые изменения. Теперь, после активации любого из листов, входящих в группу, Вы сможете продолжить работу с группой выделенных листов.
  • Private Sub Workbook_SheetActivate(ByVal Sh As Object)
        On Error GoTo ErrHandler '
        Select Case LCase(Sh.Name)
            Case "архив", "копия": iSheets = Array("Архив", "Копия")
            Case "бухгалтер", "директор": iSheets = Array("Бухгалтер", "Директор")
            Case "семенов", "петров", "отчет": iSheets = Array("Семенов", "Петров", "Отчет")
            Case Else: Exit Sub
        End Select
        Me.Worksheets(iSheets).Select
    ErrHandler:
        Select Case Err.Number
            Case 9: MsgBox "Отсутствует лист(ы) с указанным именем", , ""
            Case 1004: MsgBox "Листы не должны быть скрытыми", , ""
        End Select
    End Sub
    [ Как одновременно (синхронно) изменять данные и параметры форматирования сразу в нескольких рабочих листах ? ]
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Для того, чтобы синхронно изменять данные (значения, формулы) сразу в нескольких нужных рабочих листах, в т.ч. и скрытых, скопируйте нижеприведённый код в модуль ThisWorkbook(ЭтаКнига) нужной рабочей книги.
  • Option Compare Text

    Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
        On Error GoTo ErrHandler
        Select Case Sh.Name
            Case "Лист1", "Лист3": iSheets = Array("Лист1", "Лист3")
            Case "Лист2", "Лист4": iSheets = Array("Лист2", "Лист4")
            Case Else: Exit Sub
        End Select
        Application.EnableEvents = False
        Dim iTarget As Range
        For Each iTarget In Target.Areas
            Me.Worksheets(iSheets).FillAcrossSheets Range:=iTarget
            'Закоментируйте/удалите эту строку
            'если Вы намерены использовать следующие варианты
            'Me.Worksheets(iSheets).FillAcrossSheets Range:=iTarget, Type:=xlFillWithContents
            'Раскоментируйте эту строку
            'если необходимо заполнить листы только содержимым
            'Me.Worksheets(iSheets).FillAcrossSheets Range:=iTarget, Type:=xlFillWithFormulas
            'Раскоментируйте эту строку
            'если необходимо заполнить листы только формулами
        Next
    ErrHandler:
        Application.EnableEvents = True
        If Err.Number = 9 Then _
           MsgBox "Отсутствует лист(ы) с указанным именем", vbCritical, ""
    End Sub
    Комментарий : Если хотя бы один из диапазонов, где произошли изменения (+ рабочий лист) будет защищён, то ошибки не возникнет, но и синхронизации не произойдёт.

    [ Как быстро скопировать данные и/или форматирование выделенного диапазона в теже диапазоны других листов ? ]
  • Ответ :

    Вариант I.
  • Range("A1").Value = "m" & ChrW(179)
    Вариант II.
    With Range("A1")
         .Value = "m3"
         '.Characters(Start:=2).Font.Superscript = True
         .Characters(Start:=2, Length:=1).Font.Superscript = True
    End With

  • Ответ :

    Ниже приведены три варианта вызова диалогового окна Мастер функций для ввода (или редактирования) формулы в ячейку "A1" активного рабочего листа.
  • Range("A1").FunctionWizard
    Range("A1").Activate
    Application.Dialogs(xlDialogFunctionWizard).Show
    Range("A1").Activate
    Application.CommandBars.FindControl(Id:=385).Execute
    Комментарий :
  • Если выбранная ячейка, а также рабочий лист, будут защищены, то при использовании первых двух вариантов, Вы получите ошибку.
  • Однако, именно первые два варианта позволяют определить была или нет введена формула (см. далее)
  • Третий вариант требует наличия стандартной команды Функция..., причём, эта команда не должна быть заблокирована и этой кнопке не должен быть назначен макрос.
  • If Range("A1").FunctionWizard = True Then
       MsgBox "Действие выполнено"
    Else
       MsgBox "Действие отменено"
    End If
    If Application.Dialogs(xlDialogFunctionWizard).Show = True Then
       MsgBox "Действие выполнено"
    Else
       MsgBox "Действие отменено"
    End If
    Кроме того, ввод формулы можно осуществить и в ячейку неактивного рабочего листа, а если нужная ячейка может содержать формулу, и редактирование прежней формулы не входит в Ваши планы, то и удалить содержимое.
    With ThisWorkbook.Worksheets(3).Range("A1")
         .ClearContents
         .FunctionWizard
    End With
    With Application
         .Goto Reference:=ThisWorkbook.Worksheets(3).Range("A1")
         .ActiveCell.ClearContents
         .Dialogs(xlDialogFunctionWizard).Show
    End With
    Примечание : Ячейка "A1", а также рабочий лист с индексом(номером) 3, который существует и находится в текущей рабочей книге, использованы только в качестве примера.
  • Ответ :

    Для того, чтобы после двойного клика в любой ячейке любого рабочего листа, получить возможность об'единения данных всех листов, т.е. всех ячеек с аналогичным адресом, а затем, заполнить эти ячейки полученной строкой, можно скопировать любой из двух нижеприведённых вариантов в модуль ThisWorkbook(ЭтаКнига)

    Вариант I.
  • Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)
        iAddress$ = Target.Address
        If MsgBox("Вы действительно хотите об'единить данные всех листов : " & iAddress$, vbYesNo, "") = vbYes Then
           Cancel = True
           Dim iList As Worksheet
           For Each iList In Me.Worksheets
               iResult$ = iResult$ & "," & _
               CStr(iList.Range(iAddress$).Value)
           Next

           On Error GoTo ErrHandler
           Target.Value = Mid(iResult$, 2)
           Me.Worksheets.FillAcrossSheets _
           Range:=Target, Type:=xlFillWithContents
        End If
    ErrHandler:
        If Err.Number <> 0 Then
           MsgBox Err.Description, , Err.Number
        End If
    End Sub
    Вариант II.
    Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)
        iAddress$ = Target.Address
        If MsgBox("Вы действительно хотите об'единить данные всех листов : " & iAddress$, vbYesNo, "") = vbYes Then
           Cancel = True
           Dim iList As Worksheet
           For Each iList In Me.Worksheets
               iFormula$ = iFormula$ & "&" & """,""" & "&" & _
               iList.Range(iAddress$).Address(External:=True)
           Next

           On Error GoTo ErrHandler
           iFormula$ = Mid(iFormula$, 6)
           iResult = Evaluate(iFormula$)
           If Not IsError(iResult) Then
              Target.Value = iResult
              Me.Worksheets.FillAcrossSheets _
              Range:=Target, Type:=xlFillWithContents
           Else
              MsgBox "Не срослось", vbExclamation + vbSystemModal, ""
           End If
        End If
    ErrHandler:
        If Err.Number <> 0 Then
           MsgBox Err.Description, , Err.Number
        End If
    End Sub
    Комментарий : Второй способ лучше не использовать, если существует вероятность наличия ячеек, содержащих значение ошибки. Кроме того, не рекомендуется его применение при довольно большом количестве рабочих листов.

    Общие примечания [1], [2] :
  • Если подобное об'единение нужно осуществлять только в определённом рабочем листе, то желательно использовать аналогичное событие рабочего листа, которое обязательно должно располагаться в модуле нужного листа [FAQ] Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
  • Если подобное об'единение нужно осуществлять только в определённых ячейках, диапазонах, то необходимо добавить одну проверку [FAQ157]
  • При наличии событий рабочего листа, книги, приложения, особенно тех, что выполняются после изменения значений, имеет смысл блокировать выполнение событий [FAQ99]
  • Если существует вероятность пустых ячеек и/или ячеек значение которых "" и такие ячейки не должны участвовать в об'единении, то нужно добавить соответствующую проверку.
  • В данных примерах, в качестве разделителя используется запятая (,) однако это не является обязательным условием.
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Если необходимо сразу после выделения диапазона (в т.ч. и несмежных ячеек) подсчитать ширину всех выделенных столбцов, а затем отобразить полученное значение в строке состояния, то достаточно разместить весь нижеприведённый код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        Dim iColumn As Range
        For Each iColumn In Union(Target, Target.EntireColumn).Columns
            iWidth# = iWidth# + iColumn.ColumnWidth
        Next
        'Application.DisplayStatusBar = True
        Application.StatusBar = _
        "Ширина всех выделенных столбцов : " & iWidth#
    End Sub
    Примечание :
  • Если подсчёт необходимо производить во всех рабочих листах нужной рабочей книги, то используйте событие рабочей книги : Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
  • Если подсчёт необходимо производить во всех рабочих листах всех открытых рабочих книг, то используйте аналогичное событие приложения.
  • Если существует вероятность, что строка состояния может быть скрыта, то раскомментируйте соответствующую строку.
  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    Если в определённом рабочем листе необходимо сразу после выделения ячейки или диапазона смежных ячеек привлечь внимание пользователя, к примеру, "выделить" границы диапазона красным цветом, оставив, при этом, исходные параметры форматирования без изменений, то можно проделать приблизительно следующее :

    1. В меню Вид выберите пункт Панели инструментов и команду Рисование.
    2. Кликните, например, кнопку Прямоугольник, которая имеется на появившейся стандартной панели инструментов Рисование, и разместите выбранный об'ект в любом месте нужного рабочего листа.
    3. Измените свойства и параметры форматирования (заливку, цвет, тип и толщину линии) созданой фигуры, в соответствии с Вашими требованиями. Для этого, сразу после создания об'екта, кликните правой кнопкой мышки и в появившемся контекстном меню выберите команду Формат автофигуры (или в меню Формат выберите команду Автофигура или воспользуйтесь сочетанием клавиш CTRL + 1) После чего, в появившемся стандартном диалоговом окне выделите закладку Цвета и линии и уберите заливку (используя поле Цвет в разделе Заливка), затем, выберите нужный тип линии и установите необходимую толщину и цвет линии (используя соответствующие поля в разделе Линия)
    4. Теперь, выделите закладку Защита и уберите "флажок" напротив Защищаемый объект (данный пункт можно пропустить, если Вы не собираетесь защищать рабочий лист от изменений)
    5. Выделите закладку Свойства и уберите "флажок" напротив Выводить объект на печать (данный пункт можно пропустить, если рамка дожна присутствовать и при печати)
    6. Разместите весь нижеприведённый код в модуле нужного рабочего листа [FAQ31], изменив, при необходимости, индекс(номер) или имя графического об'екта.
  • Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        If Target.Areas.Count > 1 Then Exit Sub
        
        With Me.Shapes(1) '("ColorBorder")
             .Left = Target.Left
             .Top = Target.Top
             .Width = Target.Width
             .Height = Target.Height
        End With
    End Sub

  • Ответ :

    Пример программного удаления всех букв латиницы.

    Вариант I.
  • Private Sub DeleteSymbols()
        With ThisWorkbook.Worksheets(1).UsedRange
             'Укажите свою рабочую книгу, лист и диапазон
             'Диапазон может содержать несмежные ячейки,
             'например .Range("A1:A100,F1:100,M25,IV25")
             If Not .Parent.ProtectContents Then
                For iCode% = 97 To 122
                    .Replace What:=Chr(iCode%), _
                    Replacement:="", LoolAt:=xlPart, MatchCase:=False
                Next
             Else
                MsgBox "Рабочий лист защищён и, видимо, не случайно", , ""
             End If
        End With
    End Sub
    Вариант II.
    Private Sub DeleteSymbols2()
        Const iEnglish = "qwertyuiopasdfghjklzxcvbnm"

        With ThisWorkbook.Worksheets(1).UsedRange
             If Not .Parent.ProtectContents Then
                For iCount% = 1 To Len(iEnglish)
                    .Replace What:=Mid(iEnglish, iCount%, 1), Replacement:="", LoolAt:=xlPart, MatchCase:=False
                Next
             Else
                MsgBox "Рабочий лист защищён", , ""
             End If
        End With
    End Sub
    Пример программного удаления всех букв кириллицы.

    Вариант I.
    Private Sub DeleteCyrrilicSymbols()
        With ThisWorkbook.Worksheets(1).UsedRange
             'Укажите свою рабочую книгу, лист и диапазон
             'Диапазон может содержать несмежные ячейки,
             'например .Range("A1:A100,F1:100,M25,IV25")
             If Not .Parent.ProtectContents Then
                For iCode% = 244 To 255
                    .Replace What:=Chr(iCode%), _
                    Replacement:="", LoolAt:=xlPart, MatchCase:=False
                Next
             Else
                MsgBox "Рабочий лист защищён и, видимо, не случайно", , ""
             End If
        End With
    End Sub
    Вариант II.
    Private Sub DeleteCyrrilicSymbols2()
        Const iRussian = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя"

        With ThisWorkbook.Worksheets(1).UsedRange
             If Not .Parent.ProtectContents Then
                For iCount% = 1 To Len(iRussian)
                    .Replace What:=Mid(iRussian, iCount%, 1), Replacement:="", LoolAt:=xlPart, MatchCase:=False
                Next
             Else
                MsgBox "Рабочий лист защищён", , ""
             End If
        End With
    End Sub
    Комментарий :
  • Для того, чтобы удалить только строчные буквы, достаточно убрать необязательный именованный аргумент MatchCase
  • Для того, чтобы удалить только ПРОПИСНЫЕ буквы, достаточно убрать необязательный именованный аргумент MatchCase и изменить коды символов на 65 To 95 (латиница) и 192 To 223 (кириллица) (вариант I), или изначально использовать прописные буквы (вариант II)
  • Для того, чтобы удалить букву ё, Ё можно использовать следующие коды символов 184, 168
  • В Excel 97 появилась возможность удаления ненужных букв(символов) даже в защищённых ячейках, и для этого, достаточно воспользоваться следующим советом.
  • В Excel XP появилась возможность замены в незащищённых ячейках защищённого рабочего листа (причём, без использования предыдущего совета)
    If Not .Locked Or Not .Parent.ProtectContents Then
  • Ответ : Скачать пример

    Если Вам необходимо подсчитать общее количество букв кириллицы (а-Я), латиницы (a-Z), а также цифр (0-9), которые "содержатся" в ячейках всех рабочих листов активной рабочей книги, то Вы можете просто использовать макрос CountChars_InValues2
  • Private Type Counter
        Russian As Long
        English As Long
        ArabNum As Long
    End Type
    
    Private Sub CountChars_InValues2()
        Dim iList As Worksheet, iColumn As Range
        Dim iResult As Counter, iArrText As Variant
    
        For Each iList In ActiveWorkbook.Worksheets
            For Each iColumn In iList.UsedRange.Columns
                iArrText = iColumn.Value '.FormulaLocal
                If IsArray(iArrText) = True Then
                   GetCountChars iArrText, iResult
                Else
                   GetCountChars Array(iArrText), iResult
                End If
            Next
        Next
        
        MsgBox "Количество символов :" & vbCrLf & vbCrLf & _
        "Кириллица (а-я) = " & iResult.Russian & vbCrLf & _
        "Латиница (a-z) = " & iResult.English & vbCrLf & _
        "Цифры (0-9) = " & iResult.ArabNum, vbInformation, ""
    End Sub
    
    Private Sub GetCountChars(iArrText As Variant, iResult As Counter)
         Dim iCount%, tempText$, iText As Variant
    
         For Each iText In iArrText
             If Not IsError(iText) Then
                tempText = CStr(iText) '
                For iCount = 1 To Len(tempText) 'Len(iText)
                    Select Case Asc(Mid$(tempText, iCount, 1))
                        Case 168, 184, 192 To 255
                           iResult.Russian = iResult.Russian + 1
                        Case 65 To 90, 97 To 122
                           iResult.English = iResult.English + 1
                        Case 48 To 57
                           iResult.ArabNum = iResult.ArabNum + 1
                    End Select
                Next
             End If
        Next
    End Sub
    Комментарий : Обратите внимание на то, что :
  • При подсчёте игнорируются ячейки, содержащие значения ошибок
  • Если ячейка содержат только логическое значение ИСТИНА или ЛОЖЬ, то в подсчёте участвует текст True и False (Excel 2000 и старше)
  • Если ячейка содержат только дату/время, то анализируется количество дней, т.е. вместо 24.07.2004 12:34:36 в подсчёте будет участвовать 38192,5240277778
  • Ответ :

    Если необходимо определить наличие текста (который может быть как константой, так и результатом вычисления формулы) в указанной ячейке, то :

    Вариант I, II, III, IV
  • If Application.IsText(Range("A1")) = True Then
       MsgBox "Ячейка содержит текст"
    Else
       MsgBox "Ячейка не содержит текст"
    End If
    If WorksheetFunction.IsText(Range("A1")) = True Then
       MsgBox "Ячейка содержит текст"
    Else
       MsgBox "Ячейка не содержит текст"
    End If
    If VarType(Range("A1")) = vbString Then
       MsgBox "Ячейка содержит текст"
    Else
       MsgBox "Ячейка не содержит текст"
    End If
    If TypeName(Range("A1").Value) = "String" Then
       MsgBox "Ячейка содержит текст"
    Else
       MsgBox "Ячейка не содержит текст"
    End If
    If Evaluate("Type(A1)") = 2 Then '[Type(A1)] = 2
       MsgBox "Ячейка содержит текст"
    Else
       MsgBox "Ячейка не содержит текст"
    End If

  • Ответ :

    Вариант I.

    Если Вам необходимо строгое соответствие, т.е. кроме искомого текста, в ячейке не должно быть других символов, то можно использовать обычное сравнение, например :
  • iText = "искомый текст"

    If CStr(Range("A1")) = iText Then
       MsgBox "Ячейка, содержит нужный текст"
    Else
       MsgBox "Здесь нет нужного текста"
    End If
    Если Вам необходимо определить начинается/заканчивается ли текст в ячейке искомым, то используйте соответствующие VB функции :
    If Left(Range("A1"), Len(iText)) = iText Then
       MsgBox "Текст начинается на " & iText
    Else
       MsgBox "Нет"
    End If
    If Right(Range("A1"), Len(iText)) = iText Then
       MsgBox "Текст заканчивается на " & iText
    Else
       MsgBox "Нет"
    End If
    Комментарий : Обратите внимание на то, что по-умолчанию, сравнение строк происходит с учётом регистра символов, т.е. "текст" <> "ТексТ" <> "ТЕКСТ" , если Вас это не устраивает, то можно предварительно преобразовать текст к нижнему / верхнему регистру, например :
    If LCase(Range("A1")) = LCase(iText) Then
       MsgBox "Ячейка, содержит нужный текст"
    Else
       MsgBox "Здесь нет ничего интересного"
    End If
    Вариант II.
    iText = "Искомый текст"

    If InStr(Range("A1"), iText) > 0 Then
       MsgBox "Ячейка, содержит нужный текст"
    Else
       MsgBox "Здесь нет нужного текста"
    End If
    Комментарий : Здесь сравнение строк также происходит с учётом регистра символов, если это неприемлемо, то используйте необязательный аргумент Compare , т.е.
    iText = "Искомый текст"

    If InStr(1, Range("A1"), iText, vbTextCompare) > 0 Then
       MsgBox "Ячейка, содержит нужный текст"
    Else
       MsgBox "Здесь нет нужного текста"
    End If
    Вариант III.
    iText = "искомый текст"

    If Application.CountIf(Range("A1"), "*" & iText & "*") = 1 Then
       MsgBox "Ячейка содержит нужный текст"
    Else
       MsgBox "Ничего не найдено"
    End If
    Если Вам необходимо определить начинается/заканчивается ли текст в ячейке искомым, то используйте символ(ы) подстановки следующим образом :
    Application.CountIf(Range("A1"), iText & "*")
    Application.CountIf(Range("A1"), "*" & iText)
    Если же необходимо определить строгое соответствие, т.е. кроме искомого текста, в ячейке не должно быть других символов, то уберите символы подстановки, т.е.
    iText = "искомый текст"

    If Application.CountIf(Range("A1"), iText) = 1 Then
       MsgBox "Ячейка содержит нужный текст"
    Else
       MsgBox "Ничего не найдено"
    End If
    Комментарий : Обратите внимание на то, что стандартная функция рабочего листа =СЧЁТЕСЛИ() , которая используется в данном примере, не чувствительна к регистру, поэтому "текст" = "ТексТ" = "ТЕКСТ"

    Вариант IV.
    iText = "искомый текст"

    If Not Range("A1").Find(iText, , xlValues, xlPart) Is Nothing Then
       MsgBox "Ячейка содержит нужный текст"
    Else
       MsgBox "Ничего не найдено"
    End If
    Если же Вам необходимо определить начинается/заканчивается ли текст в ячейке искомым, то используйте символ(ы) подстановки, т.е.
    Range("A1").Find(iText & "*", , xlValues, xlWhole)
    Range("A1").Find("*" & iText, , xlValues, xlWhole)
    Если же необходимо определить строгое соответствие, т.е. кроме искомого текста, в ячейке не должно быть других символов, то просто замените константу xlPart на xlWhole
    iText = "искомый текст"

    If Not Range("A1").Find(iText, , xlValues, xlWhole) Is Nothing Then
       MsgBox "Ячейка содержит нужный текст"
    Else
       MsgBox "Ничего не найдено"
    End If
    Если же, кроме строго соответствия, Вам важен ещё и регистр, то используйте также необязательный аргумент MatchCase
    If Not Range("A1").Find(iText, , xlValues, xlWhole, , , True) Is Nothing Then
       MsgBox "Ячейка содержит нужный текст"
    Else
       MsgBox "Ничего не найдено"
    End If
    If Not Range("A1").Find(What:=iText, LookIn:=xlValues, _
       LookAt:=xlWhole, MatchCase:=True) Is Nothing Then
       MsgBox "Ячейка содержит нужный текст"
    Else
       MsgBox "Ничего не найдено"
    End If
    Вариант V.
    iText = "искомый текст"

    If Range("A1") Like "*" & iText & "*" Then
       MsgBox "Ячейка содержит нужный текст"
    Else
       MsgBox "Ничего не найдено"
    End If
    Если же Вам необходимо определить начинается/заканчивается ли текст в ячейке искомым, то используйте символ(ы) подстановки, т.е.
    Range("A1") Like iText & "*"
    Range("A1") Like "*" & iText
    Комментарий : Обратите внимание на то, что оператор Like чувствителен к регистру, поэтому "текст" <> "ТексТ" <> "ТЕКСТ" и если подобное сравнение Вас не устраивает, то можно либо преобразовать текст к нижнему / верхнему регистру, либо разместить в самом начале модуля следующую инструкцию Option Compare Text
    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

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