Microsoft Excel:

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


Rambler's Top100


Counter CO.KZ


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

  1. Как присвоить имя ячейке средствами VBA 2004
  2. Как присвоить имя ячейке средствами VBA, так чтобы это имя не отображалось в списке имён ? 2004
  3. Как заменить текст/часть текста в ячейках рабочего листа ? 10.06.2006
  4. Как заменить часть текста в ячейке рабочего листа ? 05.10.2016
  5. Как определить наличие именованных ячеек, диапазонов, формул и их количество ? 05.04.2005
  6. Как определить содержит ли текст непечатаемые символы ? 10.03.2007
  7. Как определить количество ячеек в указанном диапазоне ? 10.10.2010
  8. Как подсчитать количество ячеек, содержащих числа, а также текст ? 10.10.2010
  9. Как подсчитать количество пустых ячеек в указанном диапазоне ? 21.02.2009
  10. Как программно удалить все непечатаемые символы из ячеек указанного диапазона ? 10.03.2007
  11. Как обнаружить лидирующий апостроф в ячейке ? 11.02.2007
  12. Как найти все ячейки, содержащие значения не равные заданному (без цикла и фильтра) ? 01.09.2009
  13. Как найти все ячейки, содержащие даты опредёленного месяца и года ? 31.03.2012
  14. Как найти все ячейки, содержащие даты опредёленного месяца, а затем скрыть все строки с этими ячейками ? 30.08.2016
  15. Как в активном рабочем листе найти все ячейки содержащие буквы английского алфавита (латиница) и изменить цвет заливки найденных ячеек ? 18.02.2007
  16. Как удалить пользовательский формат из всех ячеек книги ? 24.04.2014
  17. Как в нужном рабочем листе найти непустые ячейки, где установлены определённые параметры форматирования ? 23.03.2007
  18. Как в нужном рабочем листе найти ячейки, содержащие определённые слова, и выделить эти слова, например, красным цветом ? 26.06.2010
  19. Как в конкретном диапазоне изменить цвет заливки у ячеек, содержащих отрицательные числа ? 12.12.2014
  20. Как в конкретном диапазоне изменить параметры форматирования, например, цвет заливки и шрифта - у ячеек, содержащих определённый текст [без цикла] ? 03.05.2016
  21. Как сделать так, чтобы при программном изменении данных ячеек, не выполнялись события : Worksheet_Change, Workbook_SheetChange ? 21.12.2006
  22. Как запретить изменение данных в диапазоне (т.е. запретить изменение данных более чем в одной ячейке) ? 07.03.2007
  23. Как запретить выделение нескольких ячеек, в т.ч. и несмежных ? 21.06.2007
  24. Как программно отображать примечание при активации ячейки ? 21.06.2007
  25. Как при изменении данных в ячейках определённого диапазона - автоматически добавить примечание с датой и временем этого изменения ? 18.03.2007
  26. Как сделать так, чтобы при изменении данных, пересчитывались только зависимые ячейки этого рабочего листа ? 20.02.2007
  27. Как отсортировать диапазон содержащий более трёх столбцов ? 25.02.2007
  28. Как создать квадратную ячейку ? 08.01.2010
    [1] [2] [2 err] [3] [4] [5] [6]


  • Ответ : Скачать пример

    Вариант I.
  • Range("A5").Name = "фигня"
    Вариант II.
    Names.Add Name:="фигня", RefersTo:="=$A$5", Visible:=True 'For ActiveSheet
    Names.Add Name:="фигня", RefersTo:="=Лист1!$A$5", Visible:=True
    Примечание :
  • - Вы можете также обращаться к ячейке используя другие методы [Как обратится к ячейке]
  • Ответ :

    Вариант I.
  • Names.Add Name:="фигня", RefersTo:="=$A$5", Visible:=False 'For ActiveSheet
    Names.Add Name:="фигня", RefersTo:="=Лист1!$A$5", Visible:=False
    Вариант II.
    Range("A5").Name = "фигня"
    Range("A5").Name.Visible = False
    Range("A5").Name = "фигня"
    Range("фигня").Name.Visible = False
    Для того чтобы скрыть уже существующее имя, используйте этот код :
    Names("фигня").Visible = False
    Range("фигня").Name.Visible = False

  • Ответ :
  • iCountAllNames = ActiveWorkbook.Names.Count

    If iCountAllNames = 0 Then
       MsgBox "Имён нет"
    Else
       MsgBox "Имён : " & iCountAllNames & " шт."
    End If
    Для рабочего листа мы можем узнать количество количество имён только уровня рабочего листа
    iCountLocalNames = ActiveSheet.Names.Count

  • Ответ :

  • Если необходимо заменить текст без учёта регистра, т.е. строчные и прописные буквы не должны различаться, и ячейки, где происходит замена, могут содержать другие символы, то :
  • Worksheets(1).UsedRange.Replace _
    What:="Иванов", Replacement:="Петров", LookAt:=xlPart
    Worksheets(1).UsedRange.Replace _
    What:="*Иванов*", Replacement:="Петров", LookAt:=xlWhole
  • Если необходимо заменить текст без учёта регистра, но ячейки не могут содержать другие символы, то :
  • Worksheets(1).UsedRange.Replace _
    What:="Иванов", Replacement:="Петров", LookAt:=xlWhole
  • Если необходимо заменить текст с учётом регистра символов, т.е. строчные и прописные буквы должны различаться, и ячейки не могут содержать других символов, то :
  • Worksheets(1).UsedRange.Replace _
    What:="Иванов", Replacement:="Петров", LookAt:=xlWhole, MatchCase:=True
    Примечание : При замене, как и при поиске, допускается использование символов подстановки ? и *
  • Ответ :

    Для того, чтобы заменить часть текста в одной ячейке, можно использовать предыдущий вариант, разумеется, заменив диапазон на нужную ячейку, например A1
  • Private Sub ReplaceTextInCell()
        iText1$ = "Иванов"
        iText2$ = "Петров-Задунайский"

        Range("A1").Replace iText1$, iText2$, xlPart
    End Sub
    Комментарий : Если в ячейке есть текст, параметры форматирования которого, отличаются от остального текста, то после замены весь текст станет единообразен.

    Вариант II.
    Private Sub ReplaceTextInCell2() 'Microsoft Excel 2000
        iText1$ = "Иванов"
        iText2$ = "Петров-Задунайский"

        Range("A1") = Replace(Range("A1"), iText1$, iText2$)
    End Sub
    Комментарий : После такой замены, ко всему тексту будут применены параметры форматирования - самого первого символа.

    Вариант III.

    Если же Вы хотите произвести замену и, при этом, сохранить параметры форматирования у текста, который не подлежит замене, то :
    Private Sub ReplaceTextInCell3()
        iText1$ = "Иванов"
        iText2$ = "Петров-Задунайский"
        iPos% = InStr(Range("A1"), iText1$)

        Do Until iPos% = 0
           Range("A1").Characters(iPos%, Len(iText1$)).Text = iText2$
           iPos% = InStr(Range("A1"), iText1$)
        Loop
    End Sub
    Примечание : Если необходимо не заменить, а удалить ненужный текст, то во всех вариантах, достаточно просто указать iText2$ = ""
  • Ответ :
    Если необходимо определить содержит ли текст непечатаемые символы, то для решения этой задачи, можно воспользоваться стандартной функцией рабочего листа =ПЕЧСИМВ()
  • If "искомый  текст" <> Application.Clean("искомый  текст") Then
       MsgBox "Текст содержит непечатаемые символы"
    Else
       MsgBox "Текст не содержит непечатаемых символов"
    End If
    Если текст может находиться в ячейке рабочего листа, то :
    If CStr(Range("A1")) <> Application.Clean(CStr(Range("A1"))) Then
       MsgBox "Ячейка содержит непечатаемые символы"
    Else
       MsgBox "Ячейка не содержит непечатаемых символов"
    End If
    If CStr(Range("A1")) <> WorksheetFunction.Clean(CStr(Range("A1"))) Then
       MsgBox "Ячейка содержит непечатаемые символы"
    Else
       MsgBox "Ячейка не содержит непечатаемых символов"
    End If
    Комментарий : Использование Basic функции CStr позволяет всегда получить корректный результат сравнения и избежать проверки на наличие значения ошибки.
  • Ответ :
    Если необходимо определить сколько ячеек содержит диапазон, в т.ч. и диапазон несмежных ячеек, то для этого достаточно использовать свойство Count
  • iCount = ThisWorkbook.UsedRange.Count
    или
    iCount = ThisWorkbook.UsedRange.Cells.Count

  • Ответ :

    Для того, чтобы программно подсчитать количество ячеек, содержащих числа, можно воспользоваться следующим способом :
  • iCountNum = Application.Count(ThisWorkbook.Worksheets(1).Range("A1:A100"))
    iCountNum = WorksheetFunction.Count(ThisWorkbook.Worksheets(1).Range("A1:A100"))
    iCountNum = [Count([ИмяОткрытойКниги.xls]ИмяЛиста!A1:A100)]
    А для того, чтобы программно подсчитать количество ячеек, содержащих текст, можно воспользоваться следующим способом :
    iCountText = Application.CountIf(ThisWorkbook.Worksheets(1).Range("A1:A100"), "*")
    iCountText = WorksheetFunction.CountIf(ThisWorkbook.Worksheets(1).Range("A1:A100"), "*")
    iCountText = [CountIf([ИмяОткрытойКниги.xls]ИмяЛиста!A1:A100, "*")]
    Примечание : Если имя листа, книги может содержать некоторые символы (перечень появится позже, но наиболее часто встречающийся, это, конечно же, пробел), то при применении последнего варианта используйте следующий синтаксис :
    '[ИмяОткрытойКниги.xls]ИмяЛиста'!Диапазон

  • Ответ : Скачать пример
  • Private Sub CleanSymbol()
        With ThisWorkbook.Worksheets(1).Range("A1:A100,B5,C10:C50")
             If Not .Locked Or Not .Parent.ProtectContents Then
                Dim iRange As Range, iCell As Range
                Set iRange = .Cells
                With Application
                     .EnableCancelKey = xlDisabled
                     .ScreenUpdating = False
                     .DisplayAlerts = False
                     .EnableEvents = False
                     .Calculation = xlManual
                     For Each iCell In iRange
                         If .IsText(iCell) Then iCell = .Clean(iCell)
                     Next
                     .Calculation = xlAutomatic
                     .EnableEvents = True
                     .DisplayAlerts = True
                     .ScreenUpdating = True
                     .EnableCancelKey = xlInterrupt
                End With
             Else
                MsgBox "Диапазон " & .Address(External:=True) & _
                vbCrLf & "защищён. Возможно частично ...", vbCritical, ""
             End If
        End With
    End Sub
    Примечание : Для программного изменения значений защищённых ячеек можно использовать этот [FAQ42]

    Если же речь идёт о диапазоне смежных ячеек, который не содержит логических значений, то в таком случае можно обойтись без цикла, т.е.
    With ThisWorkbook.Worksheets(1).Range("A1:A100")
         .Value = Application.Clean(.Cells)
    End With
    With ThisWorkbook.Worksheets(1).Range("A1:A100")
         .Value = Application.Clean(.Value)
    End With
    
    Комментарий :
  • Удаление непечатаемых символов приведёт к замене формул на значения, которые эти формулы возвращают (при условии, что в указанном диапазоне есть формулы)
  • Выполнение этого макроса приведёт к потере частичного форматирования ячейки.
  • Отключение обновления экрана, установка ручного режима пересчёта и т.д. используется исключительно для ускорения выполнения макроса и не носит обязательного характера. Тем не менее, я настоятельно рекомендую использовать эти свойства при работе с MS Excel, естественно с учётом поставленных задач и их особенностей.
  • Ответ : Скачать пример
  • If Range("A1").PrefixCharacter = "'" Then
       MsgBox "Данная ячейка содержит лидирующий апостроф"
    Else
       MsgBox "Данная ячейка не содержит лидирующего апострофа"
    End If
    MsgBox "Данная ячейка " & IIf(Range("A1").PrefixCharacter = "'", _
    "содержит лидирующий апостроф", "не содержит лидирующего апострофа")
    Bonus : Небольшой пример "поиска" ячеек содержащих лидирующий апостроф с последующим изменением цвета заливки/узора этих ячеек.
    Private Sub ChangeColor_PrefixCell()
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Worksheets(1).Range("A2:D100")
         If .Parent.ProtectContents = True Then
            MsgBox "Снимите защиту листа", vbCritical, ""
            Exit Sub
         End If
         On Error Resume Next
         Dim iRange As Range, iCell As Range
         Set iRange = .SpecialCells(xlConstants, xlTextValues)
         If Not iRange Is Nothing Then
            iRange.FormatConditions.Delete          '* примечание автора
            ThisWorkbook.Colors(3) = RGB(255, 0, 0) '* примечание автора
            For Each iCell In iRange
                If iCell.PrefixCharacter = "'" Then
                   iCell.Interior.ColorIndex = 3
                   iCell.Interior.Pattern = xlAutomatic
                End If
            Next
         End If
    End With
    
    Application.ScreenUpdating = True
    
    End Sub
    Примечание :
  • Удаление условного форматирования используется потому, что параметры форматирования, установленные с его помощью, имеют более высокий приоритет над всеми остальными.
  • Восстановление первоначального цвета обусловлено тем, что в Excel допускается создание пользовательского цвета, путём изменения любого цвета стандартной палитры в т.ч. и красного (3)
  • В MS Excel 95 строку, к которой относится первое примечание, необходимо удалить.
  • Ответ :

    Если необходимо найти ячейки, содержащие значения не равные заданному (т.е. предположим, что нам нужны ячейки не содержащие текст "Иванов" 'или число 123), причём, без перебора всех ячеек диапазона и применения фильтра, то для этого можно воспользоваться следующим вариантом :
  • Private Sub DifferenceLite()
        iValue = "Иванов" '123

        Dim iCell As Range, iDifference As Range
        Set iCell = [A1:A100].Find(iValue, , xlValues, xlPart)
        If Not iCell Is Nothing Then _
           Set iDifference = [A1:A100].ColumnDifferences(iCell)
    End Sub
    Примечание :
  • В указанном диапазоне обязательно должна быть, по крайней мере, одна ячейка, содержащая значение равное заданному, т.е. в данном примере, это текст "Иванов" 'или число 123
  • В указанном диапазоне обязательно должна быть, по крайней мере, одна ячейка, не содержащая заданное значение.
  • Private Sub DifferenceLite2()
        Dim iSource As Range, iDifference As Range, iValue
        Set iSource = ThisWorkbook.Worksheets(1).[C1:C100]

        iValue = "Иванов" '123

        If Application.Min(Application.CountIf(iSource, Array(iValue, "<>" & iValue))) > 0 Then Set iDifference = iSource.ColumnDifferences(iSource.Find(iValue, , xlValues, xlPart))
    End Sub
    Комментарий :
  • Кроме того, применение метода ColumnDifferences вызывает событие Worksheet_SelectionChange и аналогичные события рабочей книги, приложения. Впрочем, это можно предотвратить, если использовать этот совет.
  • Если рабочий лист защищён, то использование вышеупомянутого метода приведёт к возникновению ошибки, которую можно избежать, если воспользоваться этим советом.
  • Ответ : Скачать пример

    Если необходимо найти все ячейки, содержащие даты (не являющиеся результатом вычисления формул) определённого месяца и года, то можно организовать поиск, начиная первым и заканчивая последним днём указанного месяца и года, но можно и воспользоваться символами подстановки, например, *
  • Private Sub Find_DateValue()
        Dim iMonth%, iYear%, iAddress$
        Dim iSource As Range, iCell As Range
        
        iMonth = 3 : iYear = 2012
        
        Set iSource = ThisWorkbook.Worksheets(1).UsedRange 'Лист1.UsedRange
        Set iCell = iSource.Find(iMonth & "/*/" & iYear, , xlFormulas, xlWhole)
        If Not iCell Is Nothing Then
           iAddress = iCell.Address
           Do
                Set iCell = iSource.FindNext(iCell)
           Loop While iAddress <> iCell.Address
        Else
           MsgBox "Ничего не найдено", , ""
        End If
    End Sub
    Комментарий : Если год не важен, то замените iYear на "*" или "????"
  • Ответ :

    Если необходимо найти все ячейки, содержащие даты (не являющиеся результатом вычисления формул) определённого месяца, а затем скрыть все строки, содержащие найденные ячейки, то можно организовать поиск (метод Find и FindNext) и воспользоваться символом подстановки *
  • Private Sub HiddenChooseMonth()
        Dim iCell As Range, iSource As Range, iColumn As Range
        Dim iAddress$, iMonth%: iMonth = 1  'Укажите свой месяц
        
        Set iColumn = Range("A:A")  'Укажите свой столбец
        Set iCell = iColumn.Find(iMonth & "/*/*", , xlFormulas)
        
        If Not iCell Is Nothing Then
           iAddress = iCell.Address: Set iSource = iCell
           Do
                Set iCell = iColumn.FindNext(iCell)
                Set iSource = Union(iCell, iSource)
           Loop While iAddress <> iCell.Address
           iSource.EntireRow.Hidden = True
        Else
           MsgBox "Ничего не найдено", , ""
        End If
    End Sub
    Комментарий : Если год важен, то замените второй символ "*" на необходимый год, например, 2012 Если год должен быть переменным, то используйте вариант из предыдущего совета.
  • Ответ : Скачать пример
  • Private Sub Find_EnglishSymbol()
        If TypeOf ActiveSheet Is Worksheet Then
           If ActiveSheet.ProtectContents = True Then
              MsgBox "Рабочий лист защищён", vbCritical, ""
              Exit Sub
           End If
        Else
           MsgBox "Поиск можно осуществлять только в ячейках", vbCritical, ""
           Exit Sub
        End If
        
        Application.ScreenUpdating = False
        
        Const iEnglish = "QWERTYUIOPASDFGHJKLZXCVBNM"
        
        With ActiveSheet.UsedRange
             Dim iCell As Range
             For iCount% = 1 To Len(iEnglish)
                 Set iCell = .Find(What:=Mid( _
                 iEnglish, iCount%, 1), LookIn:=xlValues, LookAt:=xlPart)
                 If Not iCell Is Nothing Then
                    iAddress$ = iCell.Address
                    Do
                       If Application.IsText(iCell.Value) = True Then
                          'Эта проверка необходима, т.к. логические значения
                          'и значения ошибок содержат латиницу.
                          iCell.Interior.Color = vbRed
                       End If
                       Set iCell = .FindNext(After:=iCell)
                    Loop While Not iCell Is Nothing _
                    And  iCell.Address <> iAddress$
                 End If
             Next
        End With
      
        Application.ScreenUpdating = True
    End Sub
    Примечание :
  • Если рабочий лист защищён в отношении содержимого, то изменение параметров форматирования, даже в незащищённых ячейках, без дополнительных ухищрений, невозможно. Исключением является MS Excel XP.
  • Не забывайте, что параметры форматирования, установленные с помощью условного форматирования, имеют более высокий приоритет над всеми остальными. Поэтому, если к ячейке, содержащей хотя бы одну букву английского алфавита будет применено условное форматирование, то изменение цвета заливки не принесёт ожидаемого эффекта. В этом случае необходимо, либо удалить условное форматирование, либо изменить цвет заливки с его помощью (используя первое условие)
  • Не забывайте, что в Excel допускается создание пользовательского цвета, путём изменения любого цвета стандартной палитры. Поэтому, если в рабочей книге был создан пользовательский цвет на основании красного, то программная установка "красного" цвета приведёт к появлению заливки содержащий пользовательский цвет.
  • Если вместо активного листа указать существующий рабочий лист, то из первоначального примера можно убрать соответствующую проверку.

    Если диапазон для поиска латиницы относительно небольшой, то можно воспользоваться прямым перебором всех ячеек, например :
  • Option Compare Text
    
    Private Sub Search_EnglishSymbol()
        Dim iCell As Range
        With ThisWorkbook.Worksheets(1)
             If Not .ProtectContents Then
                Application.ScreenUpdating = False
                For Each iCell In .Range("A1:C300")
                    If CStr(iCell.Value) Like "*[A-Z]*" Then _
                       iCell.Interior.Color = vbRed
                Next
                Application.ScreenUpdating = True
             Else
                MsgBox "Рабочий лист защищён", vbCritical, ""
             End If
        End With
    End Sub
    Если диапазон содержит неизвестное количество ячеек, то можно, например, совместить перебор столбцов и элементов массива :
    Private Sub Search_EnglishSymbol2v2()
        Dim iColumn As Range, iRow&, iArr 'As Variant
        With ThisWorkbook.Worksheets(1)
             If .ProtectContents = True Then
                MsgBox "Рабочий лист защищён", vbCritical, "": Exit Sub
             End If
             Application.ScreenUpdating = False
             For Each iColumn In .UsedRange.Columns
                 iArr = iColumn.Value
                 For iRow = 1 To UBound(iArr) 'iColumn.Rows.Count
                     If CStr(iArr(iRow, 1)) Like "*[A-z]*" Then _
                     iColumn.Cells(iRow).Interior.Color = vbRed
                 Next
             Next
             Application.ScreenUpdating = True
        End With
    End Sub
    Особенности MS Excel 2000, XP
    В этих версиях нужно использовать проверку из предыдущего примера Application.IsText()
  • Ответ :

    Для того, чтобы удалить пользовательский формат из всех рабочих листов конкретной книги достаточно использовать метод DeleteNumberFormat об'екта Workbook
  • ThisWorkbook.DeleteNumberFormat "General;;"
    Комментарий :
  • Обратите внимание, если любой из рабочих листов будет защищён, то Вы получите ошибку.
  • Пользовательский формат всегда необходимо указывать т.к. хранит его Excel, т.е. если к ячейкам может быть применён следующий формат [Синий]# ##0,00р.;[Красный]-# ##0,00р.;"-" то удалять нужно [Blue]#,##0.00$;[Red]-#,##0.00$;"-"

    Совет : Если с правильным указанием формата возникнут проблемы, например, из-за его сложности, то можно выделить ячейку, к которой он был применён, и выполнить следующий код, естественно, предварительно заменив ячейку [A1] на любую пустую.
  • Range("A1") = ActiveCell.NumberFormat
    Разумеется, Вы можете обойтись и без "посредника", т.е. если Вы абсолютно уверены, что к активной ячейке (или любой другой) применён пользовательский формат, который необходимо удалить, то можно использовать следующий синтаксис. Только не следует забывать, что в случае отсутствия собственного формата, возникнет ошибка.
    ThisWorkbook.DeleteNumberFormat ActiveCell.NumberFormat

  • Ответ : Скачать пример

    Вариант I. Если диапазон для поиска непустых ячеек (где начертание шрифта установлено как полужирный и курсив) относительно небольшой, то можно воспользоваться прямым перебором всех ячеек, например :
  • Private Sub Find_Formatting()
        Dim iCell As Range
        For Each iCell In ThisWorkbook.Worksheets(1).UsedRange
            If Not IsEmpty(iCell) Then
               With iCell.Font
                    If .Bold = True And .Italic = True Then
                       MsgBox iCell.Address, ,""
                       'MsgBox используется как имитация Ваших действий
                    End If
               End With
            End If
        Next
    End Sub
    Актуально только для MS Excel XP

    Вариант II. В противном случае, можно использовать метод Find.
    Private Sub Find_FormattingXP1()
        With Application
             With .FindFormat
                  .Clear
                  .Font.Bold = True '
                  .Font.Italic = True
             End With
             With .ThisWorkbook.Worksheets(1)
                  Dim iCell As Range
                  Set iCell = .UsedRange.Find _
                  (What:="*", LookIn:=xlFormulas, SearchFormat:=True)
                  If Not iCell Is Nothing Then
                     iAddress$ = iCell.Address
                     Do
                          Set iCell = .UsedRange.Find _
                          (What:="*", After:=iCell, _
                          LookIn:=xlFormulas, SearchFormat:=True)
                          MsgBox iCell.Address, ,""
                     Loop While iCell.Address <> iAddress$
                  End If
             End With
        End With
    End Sub
    Private Sub Find_FormattingXP2()
        With Application
             With .FindFormat
                  .Clear
                  .Font.Bold = True '
                  .Font.Italic = True
             End With
             With .ThisWorkbook.Worksheets(1)
                  Dim iCell As Range
                  Set iCell = .UsedRange.Find _
                  (What:="*", LookIn:=xlFormulas, SearchFormat:=True)
                  If Not iCell Is Nothing Then
                     iAddress$ = iCell.Address
                     Do Until iCell Is Nothing
                        Set iCell = .UsedRange.Find _
                        (What:="*", After:=iCell, _
                        LookIn:=xlFormulas, SearchFormat:=True)
                        MsgBox iCell.Address, ,""
                        If iCell.Address = iAddress$ Then Exit Do
                     Loop
                  End If
             End With
        End With
    End Sub

  • Ответ : Скачать пример
  • Option Compare Text
    
    Private Sub ChangeFormatting()
    
    Application.ScreenUpdating = False
    
    Dim iCell As Range
    With ThisWorkbook.Worksheets(1).UsedRange
         For Each iWord In Array("текст", "формула", "константа")
             Set iCell = .Find _
             (What:=iWord, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
             If Not iCell Is Nothing Then
                iAddress$ = iCell.Address
                Do
                   If Not iCell.HasFormula Then
                      iPosition% = InStr(iCell.Value, iWord)
                      Do
                         With iCell.Characters _
                              (Start:=iPosition, Length:=Len(iWord))
                              .Font.Bold = True
                              .Font.Color = vbRed
                         End With
                         iPosition% = InStr(iPosition% + 1, iCell.Value, iWord)
                      Loop While iPosition% <> 0
                   End If
                   Set iCell = .FindNext(After:=iCell)
                Loop While iCell.Address <> iAddress$
             End If
         Next
    End With
    
    Application.ScreenUpdating = True
    
    End Sub
    Примечание :
  • Если нужно найти только одно слово, то в наличии цикла For Each ... Next нет никакой необходимости.
  • Если регистр символов важен, т.е. слово "константа" должно быть выделено, а слово "Константа" нет, то просто удалите/закомментируйте самую первую строку и измените значение последнего аргумента, т.е. MatchCase:=True
  • Если регистр символов не важен, но при этом использование инструкции Option Compare нежелательно, то используйте необязательный аргумент Compare VB функции InStr, т.е. InStr(Start, String1, String2, vbTextCompare) (см. второй вариант в этом примере)
  • Если рабочий лист защищён в отношении содержимого, то изменение параметров форматирования, даже в незащищённых ячейках, без дополнительных ухищрений, невозможно. Исключением является MS Excel XP.
  • Не забывайте, что параметры форматирования, установленные с помощью условного форматирования, имеют более высокий приоритет над всеми остальными. Поэтому, если к ячейке, содержащей искомое слово будет применено условное форматирование, то изменение цвета заливки не принесёт ожидаемого эффекта. В этом случае необходимо, просто удалить условное форматирование.
  • Не забывайте, что в Excel допускается создание пользовательского цвета, путём изменения любого цвета стандартной палитры. Поэтому, если в рабочей книге был создан пользовательский цвет на основании красного, то программная установка "красного" цвета приведёт к появлению заливки содержащий пользовательский цвет.
  • Ответ : Актуально для MS XP (и старше)

    Для того, чтобы в определённом диапазоне, изменить цвет заливки у ячеек, содержащих отрицательные числа (не являющихся результатом вычислений формул), можно использовать следущий макрос.
  • Private Sub SetColorMinusNumbers()
        With Application
             .FindFormat.Clear
             .ReplaceFormat.Clear
             .ReplaceFormat.Interior.Color = vbRed       
             .Range("A1:D100").Replace "-", "-", xlPart, , , , , True
        End With
    End Sub
    Если в указанном диапазоне будут также находиться ячейки, содержащие текст, формулы, в которых может встречаться знак минус, то диапазон замены можно "сузить". Кроме того, в некоторых таблицах не помешает удалить некоторые форматы, в т.ч. и условное форматирование.
    Private Sub SetColorMinusNumbers2()
        With Application
             .FindFormat.Clear
             .ReplaceFormat.Clear
             .ReplaceFormat.Interior.ColorIndex = 3
             With .Range("A1:D100")
                  .FormatConditions.Delete
                  .Interior.ColorIndex = xlNone
                  .SpecialCells(xlConstants, xlNumbers).Replace "-", "-", xlPart, , , , , True
             End With
        End With
    End Sub
    В более ранних версиях можно организовать перебор ячеек диапазона/элементов массива или же использовать поиск, вместе с дополнительной проверкой, например :
    Private Sub SetColorMinusNumbers97() 'XL97
        Dim iSource As Range, iCell As Range, iAddress$
        Set iSource = Range("A:D") '[A:D]
        Set iCell = iSource.Find("-*", , xlValues, xlWhole)
        
        If Not iCell Is Nothing Then
           iAddress = iCell.Address
           Do
                If IsNumeric(iCell) = True Then iCell.Interior.Color = vbRed
                Set iCell = iSource.FindNext(iCell)
           Loop Until iCell.Address = iAddress
        End If
    End Sub
    Если же Вы абсолютно уверены, что в указанном диапазоне нет ячеек, содержащих текст, который начинается со знака минус, например, '-100TX то можно использовать второй вариант :
    Private Sub SetColorMinusNumbers97()
        Dim iSource As Range, iCell As Range, iCount&
        Set iSource = [A:D]: Set iCell = iSource(1)
        
        For iCount = 1 To Application.CountIf(iSource, "<0")
            Set iCell = iSource.Find("-*", iCell, xlValues, xlWhole)
            iCell.Interior.Color = vbRed
        Next
    End Sub

  • Ответ : Актуально для MS XP (и старше)

    Для того, чтобы в определённом диапазоне, изменить цвет заливки и шрифта, а также добавить границу(рамку) у ячеек, содержащих нужный текст (не являющийся результатом вычислений формул), можно использовать тот же приём, что и вышеопубликованном [FAQ708]
  • Private Sub Sub SetColorFindText()
        iText$ = "Иванов"    
        With Application
             .FindFormat.Clear
             With .ReplaceFormat
                  .Clear
                  .Font.Bold = True
                  .Font.Color = vbWhite   '.Font.ColorIndex = 2
                  .Interior.Color = vbRed '.Interior.Color = 255
                  .Borders.LineStyle = xlContinuous
             End With
             .Range("A1:D100").ClearFormats
             .Range("A1:D100").Replace iText$, iText$, xlPart, , , , , True   'Частично
             '.Range("A1:D100").Replace iText$, iText$, xlWhole, , , , , True 'Полностью
        End With
    End Sub

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

    Для того, чтобы при программном изменении данных ячейки, не выполнялись соответствующие события, нужно установить значение свойства EnableEvents = False
  • Application.EnableEvents = False
    'Здесь Вы вносите необходимые изменения
    Application.EnableEvents = True
    Комментарий : После всех изменений, нужно обязательно вернуть первоначальное значение.

    Подобное блокирование событий может оказаться полезным и при выполнении самих событий, например, в тех случаях, когда в зависимости от введённых данных, необходимо изменять данные неких ячеек.
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Application.EnableEvents = False
        Dim iCell As Range
        For Each iCell In Target
            Select Case True
                Case IsEmpty(iCell):   iCell = "[Пусто]"
                Case IsDate(iCell):    iCell = "[Дата]"
                Case IsNumeric(iCell): iCell = "[Число]"
                Case IsError(iCell):   iCell = "[Ошибка]"
                Case Else:             iCell = "[Текст]"
            End Select
        Next
        Application.EnableEvents = True
    End Sub

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

    Для того, чтобы запретить изменение данных более чем в одной ячейке, разместите событие Worksheet_Change в модуле нужного рабочего листа [FAQ31]
    Если подобное ограничение должно касаться всех рабочих листов, то можно воспользоваться аналогичным событием рабочей книги Workbook_SheetChange [FAQ172]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Count > 1 Then
           Application.EnableEvents = False
           Application.Undo
           Application.EnableEvents = True
        End If
    End Sub
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Count > 1 Then
           With Application
                .EnableEvents = False
                .Undo
                .EnableEvents = True
           End With
        End If
    End Sub
    Комментарий : Обратите внимание на то, что Change - это :
  • 1. Переход в режим редактирования, в т.ч. без внесения изменений
  • 2. Редактирование данных, в т.ч. изменение формул и текста гиперссылок
  • 3. Ввод данных с клавиатуры
  • 4. Удаление данных
  • 6. Копирование, в т.ч. пустых ячеек
  • 7. Копирование с использованием Специальной вставки
  • 8. Использование команд Вырезать и Вставить
  • 9. В MS Excel 2000 + Удаление ячеек, в т.ч. строк и столбцов
  • 10.В MS Excel XP + Добавление ячеек, в т.ч. строк и столбцов
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Для того, чтобы запретить выделение более чем одной ячейки, скопируйте нижеприведённый и код и разместите его в модуле нужного рабочего листа [FAQ31]
    Если подобное ограничение должно касаться всех рабочих листов, то можно воспользоваться аналогичным событием рабочей книги Workbook_SheetSelectionChange [FAQ172]
  • Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        If Target.Count > 1 Then Target(1).Select
    End Sub

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

    Для того, чтобы создать примечание(комментарий) содержащее автора и дату + время последнего изменения ячейки/ячеек нужного диапазона, например "A1:A1000" разместите событие Worksheet_Change в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iTarget As Range, iCell As Range
        Set iTarget = Intersect(Me.Range("A1:A1000"), Target)
        If Not iTarget Is Nothing Then
           If Not Me.ProtectContents Then
              iText$ = Application.UserName & vbLf & Now
              For Each iCell In iTarget
                  iCell.NoteText Text:=iText$
              Next
           Else
              MsgBox "Для создания примечаний снимите защиту листа", , ""
           End If
        End If
    End Sub
    Примечание : Этот вариант не предназначен для работы с защищённым рабочим листом, т.к. создание комментария в таком листе вызывает ошибку, которую можно избежать, если использовать второй вариант.
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iTarget As Range, iCell As Range
        Set iTarget = Intersect(Me.Range("A1:A1000"), Target)
        If Not iTarget Is Nothing Then
           ЛистИнфо.Range("A1").NoteText Text:= _
           Application.UserName & vbLf & Now 'Chr(10)
           ЛистИнфо.Range("A1").Copy
           With Application
                .EnableEvents = False
                 iTarget.PasteSpecial Paste:=xlComments
                .CutCopyMode = False
                .EnableEvents = True
           End With
        End If
    End Sub
    Предполагается, что :
  • ЛистИнфо - это кодовое(программное) имя "промежуточного" рабочего листа, который находится в этой же рабочей книге и скрыт, т.е. значение свойства Visible установлено как xlVeryHidden. Если существует вероятность, что этот рабочий лист может быть переименован или удалён, то перед созданием комментария нужно проверить его наличие [FAQ94] заменив свойство Name на CodeName.

    Примечание : Если изменения происходят в целом диапазоне ячеек и при этом, на экране отображаются сами примечания, то на время создания/вставки комментариев можно "отключить" обновление экрана [FAQ43]

    Комментарий : [См. выше]
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Для того, чтобы при изменении данных, пересчитывались только зависимые ячейки этого рабочего листа (это бывает полезно при большом количестве формул, пересчёт которых занимает значительное время) разместите эти события в модуле ThisWorkbook(ЭтаКнига) :
  • Private Sub Workbook_Activate()
        Application.Calculation = xlManual
    End Sub
    
    Private Sub Workbook_Deactivate()
        Application.Calculation = xlAutomatic
    End Sub
    
    Private Sub Workbook_SheetChange( _
        ByVal Sh As Object, ByVal Target As Excel.Range)
        On Error Resume Next
        Target.Dependents.Calculate
    End Sub

  • Ответ : Скачать пример
  • With ThisWorkbook.Worksheets(1).Range("A1:E56")
         For iCount% = .Columns.Count To 1 Step -1
             .Sort _
              Key1:=.Item(iCount%), Order1:=xlAscending, _
              Header:=xlGuess, Orientation:=xlTopToBottom
         Next
    End With
    Предполагается, что :
  • ThisWorkbook - это текущая рабочая книга, т.е. книга в которой содержится выполняемый, в настоящий момент, код.
  • Worksheets(1) - это первый рабочий лист указанной книги.
  • "A1:E56" - это диапазон, который требуется отсортировать.
  • "A1:E1" - это диапазон, который содержит заголовки сортируемой таблицы.
  • Ответ :
  • iColumnWidth = 20.86 '4 см.
    
    With Cells(1, 1) 'Range("A1") '[A1]
         .ColumnWidth = iColumnWidth
         .RowHeight = .Width
    End With

    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

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