Microsoft Excel:

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


Rambler's Top100


Counter CO.KZ


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

  1. Как определить наличие заголовка(шапки) у таблицы ? 22.03.2011
  2. Как определить номер последней скрытой строки (без цикла) ? 27.06.2010
  3. Как в XL95, XL97 получить смещение относительно несмежных ячеек/диапазонов ? 27.06.2010
  4. Как программно найти самую первую ячейку, содержащую циклическую ссылку ? 02.11.2010
  5. Как найти все ячейки, содержащие циклические ссылки, и заменить формулу на текст формулы ? 02.04.2011
  6. Как средствами Excel сохранить данные активного рабочего листа в виде текстового файла ? 24.09.2010
  7. Как программно получить наиболее часто повторяющееся значение в ячейках диапазона ? 28.09.2010
  8. Как во всех ячейках, удалить указанный символ, если он повторяется два(или более) раза [без перебора ячеек] ? 29.09.2016
  9. Как в нужном диапазоне удалить условное форматирование ? 03.10.2010
  10. Как подсчитать количество ячеек, удовлетворяющих определённому условию, причём, только в видимых ячейках ? 22.02.2011
  11. Как после изменения данных, сделать Прописной первую букву каждого слова, преобразовав все остальные в строчные (за исключением ячеек с формулами) ? 08.08.2011
  12. Как мониторить время, затраченное на ввод данных во все ячейки диапазона ? 03.05.2016
  13. Как сделать так, чтобы после выделения конкретной ячейки, её данные можно было увеличивать/уменьшать с помощью соответствующих клавиш ? 06.01.2016
  14. Как после изменения данных в ячейке, автоматически выделить слова с ошибками ? 09.05.2015
  15. Как во всех рабочих листах активной книги - увеличить / уменьшить все числовые данные в определённом диапазоне ? 03.01.2016
  16. Как после изменения данных, найти ячейки, значения которых меньше чем, например, 0.01 и автоматически изменить их на 0.01 ? 11.06.2014
  17. Как после изменения данных в конкретной ячейке, автоматически разделить текст (по количеству символов) и перенести его в следующие ячейки этого столбца ? NEW 08.10.2017
  18. Как автоматически выводить в первом столбце дату и время, когда в ячейках происходят изменения ? 24.06.2016
  19. Как после изменения данных в определённом столбце, автоматически воспроизвести системный звуковой файл ? 02.01.2016
  20. Как суммировать вводимые числа в одной ячейке ? 30.08.2016
    [1] [2] [3] [4] [5] [6]


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

    Для того, чтобы определить есть или нет заголовок(шапка) у таблицы, можно использовать свойство ListHeaderRows об'екта Range, которое возвращает количество строк, которые Excel однозначно определяет как заголовки.
  • If Range("A1:C100").ListHeaderRows = 0 Then
       MsgBox "Заголовка, скорее всего, нет"
    Else
       MsgBox "Таблица содержит заголовки"
    End If
    If Range("A1:C100").ListHeaderRows > 0 Then
       MsgBox "Таблица содержит заголовки"
    Else
       MsgBox "Заголовка, скорее всего, нет"
    End If
    Комментарий : Обратите внимание на то, что свойство ListHeaderRows довольно "капризное". Для примера, допустим, что указанная таблица действительно существует и первая строка содержит шапку, но ячейка "B2" не содержит текста, в результате мы получим ListHeaderRows = 0
  • Ответ :

    Для того, чтобы узнать номер последней скрытой строки, причём без цикла, можно использовать нижеопубликованный вариант, естественно, учитывая особенности .SpecialCells(xlVisible)
  • With ThisWorkbook.Worksheets(1).Columns("A") '(1)
         If .SpecialCells(xlVisible).Count < .Rows.Count Then
            With Intersect(.SpecialCells(xlVisible), .Cells)
                 iRow& = .Areas(.Areas.Count).Row - 1
                 MsgBox "Номер последней скрытой строки : " & iRow&, , ""
            End With
         Else
            MsgBox "Скрытых строк скорее всего нет, или ...", , ""
         End If
    End With
    With ThisWorkbook.Worksheets(1).Columns(1) '("A")
         Dim iVisibleDiapazon As Range
         Set iVisibleDiapazon = .SpecialCells(xlVisible)
         If iVisibleDiapazon.Count < .Rows.Count Then
            With Intersect(iVisibleDiapazon, .Cells)
                 iRow& = .Areas(.Areas.Count).Row - 1
                 MsgBox "Номер последней скрытой строки : " & iRow&, , ""
            End With
         Else
            MsgBox "Скрытых строк скорее всего нет, или ...", , ""
         End If
    End With
    Комментарий : Если столбец "A" окажется скрыт, то Вы получите ошибку, которую можно избежать, если заменить скрытый на столбец на любой видимый.
  • Ответ : Актуально для MS Excel 95, 97

    Если Вы являетесь обладателем вышеуказанной версии, то, возможно, замечали, что свойство Offset применительно к несмежным ячейкам/диапазонам, возвращает смещение относительно только первой области, и если такой результат неприемлем, то вместо свойства Offset Вы можете использовать функцию MyOffset(Исходный_диапазон, Смещение_по_строкам, Смещение_по_столбцам)
  • Private Function MyOffset(Diapazon As Range, _
        Optional RowOffset&, Optional ColumnOffset&) As Range
        Dim iArea As Range
        For Each iArea In Diapazon.Areas
            If Not MyOffset Is Nothing Then
               Set MyOffset = Union(MyOffset, _
               iArea.Offset(RowOffset, ColumnOffset))
            Else
               Set MyOffset = iArea.Offset(RowOffset, ColumnOffset)
            End If
        Next
    End Function
    Private Function MyOffset(Diapazon As Range, _
        Optional RowOffset&, Optional ColumnOffset&) As Range
        With Diapazon.Areas
             Set MyOffset = .Item(1).Offset(RowOffset, ColumnOffset)
             For iCount& = 2 To .Count
                 Set MyOffset = Union(MyOffset, _
                 .Item(iCount&).Offset(RowOffset, ColumnOffset))
             Next
        End With
    End Function
    Несколько примеров использования :
    Private Sub Test()
    
        Dim iSource As Range
        Set iSource = [A3,C3,F5:H10]
        
        MsgBox iSource.Offset(7).Address
        MsgBox iSource.Offset(, 5).Address
        MsgBox iSource.Offset(0, 5).Address
        MsgBox iSource.Offset(2, 10).Address
        MsgBox iSource.Offset(-1, 1).Address
        
        MsgBox MyOffset(iSource, 7).Address
        MsgBox MyOffset(iSource, , 5).Address
        MsgBox MyOffset(iSource, 0, 5).Address
        MsgBox MyOffset(iSource, 2, 10).Address
        MsgBox MyOffset(iSource, -1, 1).Address
        
    End Sub

  • Ответ :

    Для того, чтобы в нужном рабочем листе найти самую первую ячейку, содержащую формулу, вычисление которой приводит к возникновению циклической ссылки, можно воспользоваться свойством CircularReference об'екта Worksheet
  • Dim iCell As Range
    Set iCell = Worksheets(1).CircularReference
    
    If Not iCell Is Nothing Then
       MsgBox "Первая циклическая ссылка : " & _
       iCell.Address(External:=True), , ""
    Else
       MsgBox "Нет циклических ссылок", , Лист1.Name
    End If
    If Лист1.CircularReference Is Nothing Then
       MsgBox "На нет и суда нет", , Лист1.Name
    Else
       MsgBox "Первая циклическая ссылка : " & _
       Лист1.CircularReference.Address(, , , True), , ""
    End If

  • Ответ :

    Для того, чтобы в нужном рабочем листе - найти все ячейки, содержащие циклические ссылки и заменить =формулу на '=текст_формулы, что позволит избавиться от циклической ссылки, ибо текст вычисляться не будет, можно воспользоваться нижеопубликованным макросом, естественно, указав свою рабочую книгу и рабочий лист. Обратите также своё внимание на особенность работы с формулами массивами, которая продемонстрирована в макросе ReplaceAllCircRefOnText
  • Private Sub ReplaceCircRefOnText()
        Dim iList As Worksheet, iCircRef As Range
        Set iList = ThisWorkbook.Worksheets(1)
        Set iCircRef = iList.CircularReference    
    
        Do Until iCircRef Is Nothing
           iCircRef.Value = "'" & iCircRef.Formula
           Set iCircRef = iList.CircularReference '
        Loop    
    End Sub
    Private Sub ReplaceCircRefOnText2()    
        With ActiveWorkbook.Worksheets(1)
             Dim iCircRef As Range
             Set iCircRef = .CircularReference
        
             Do Until iCircRef Is Nothing
                iCircRef = "'" & iCircRef.Formula
                Set iCircRef = .CircularReference
             Loop
        End With    
    End Sub
    Если же подобную замену необходимо осуществить во всех рабочих листах, например, текущей рабочей книги, то :
    Private Sub ReplaceAllCircRefOnText()
        Application.ScreenUpdating = False
        Dim iList As Worksheet, iCircRef As Range
        For Each iList In ThisWorkbook.Worksheets
            Set iCircRef = iList.CircularReference
        
            Do Until iCircRef Is Nothing
               If Not iCircRef.HasArray Then
                  iCircRef = "'" & iCircRef.Formula
               Else
                  iCircRef.CurrentArray = "'" & iCircRef.Formula
               End If
               Set iCircRef = iList.CircularReference '
            Loop
        Next
        Application.ScreenUpdating = True
    End Sub
    Комментарий : Если рабочий лист защищён, а формулы скрыты или ячейки защищены, то возникнет ошибка, которую можно избежать, если проверить защищён или нет рабочий лист [FAQ79]
  • Ответ : Скачать пример
  • Private Sub DiapazonSaveInTextFile()
        With Application
             If TypeName(.ActiveSheet) = "Worksheet" Then
                iFileName = .GetSaveAsFilename( _
                InitialFileName:="Archiv_" & Date$, _
                FileFilter:="Text Files (*.txt), *.txt", _
                Title:="Введите имя файла и выберите место его сохранения")
                If iFileName <> False Then
                   Dim iSource As Worksheet
                   Set iSource = .ActiveSheet
                   .ScreenUpdating = False
                   .DisplayAlerts = False '
                   With .Workbooks.Add(xlWBATWorksheet)
                        iSource.Range("A1:C100").Copy _
                        Destination:=.Worksheets(1).Range("A1")
                        'Вместо A1:C100 укажите нужный диапазон
                        .SaveAs FileName:=iFileName, FileFormat:=xlText
                        .Close saveChanges:=False
                   End With
                   .DisplayAlerts = True '
                   .ScreenUpdating = True
                Else
                   MsgBox "Для сохранения данных необходимо указать файл", , ""
                End If
             Else
                MsgBox "Активным должен быть лист имеющий ячейки", , ""
             End If
        End With
    End Sub

  • Ответ :

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

    Вариант I.
  • With Application
         iArray = .CountIf([A2:A100], [A2:A100])
         iResult = .Index([A2:A100], .Match(.Max(iArray), iArray, 0))
    End With
    With Application
         iArray = .CountIf([A2:A100], [A2:A100])
         iResult = [A2:A100].Item(.Match(.Max(iArray), iArray, 0))
    End With
    тоже самое, но более подробно и с проверкой на наличие повторов :
    Dim iDiapazon As Range, iMax&, iRow&, iArray, iResult
    Set iDiapazon = [A2:A100] 'Range("A2:A100")

    With Application
         iArray = .CountIf(iDiapazon, iDiapazon)
         iMax = .Max(iArray)
         If iMax > 1 Then
            iRow = .Match(iMax, iArray, 0)
            iResult = .Index(iDiapazon, iRow) ' = iDiapazon(iRow)
            MsgBox CStr(iResult), , ""
         Else
            MsgBox "Повторы отсутствуют", , ""
         End If
    End With
    Вариант II.
    With Application
         iResult = .Index([A2:A100], .Mode(.Match([A2:A100], [A2:A100], 0)))
    End With
    With Application
         iResult = [A2:A100].Cells(.Mode(.Match([A2:A100], [A2:A100], 0)))
    End With
    тоже самое, но с проверкой на наличие повторов и пр. :
    Dim iDiapazon As Range, iResult 'As Variant
    Set iDiapazon = Range("A2:A100") '[A2:A100]

    With Application
         iResult = .Index(iDiapazon, .Mode(.Match(iDiapazon, iDiapazon, 0)))
         'iResult = iDiapazon(.Mode(.Match(iDiapazon, iDiapazon, 0)))
         If Not .IsError(iResult) Then
            MsgBox iResult, , "Найдено : "
         Else
            MsgBox "Возможные причины :" & vbCrLf & _
            "1. нет повторов" & vbCrLf & _
            "2. есть пустые ячейки" & vbCrLf & _
            "3. есть ячейки с ошибками", , "Ничего не найдено"
         End If
    End With
    Вариант III. (по сути это также второй вариант)
    iResult = [INDEX(A2:A100,MODE(MATCH(A2:A100,A2:A100,0)))]
    Если адрес диапазона не должен быть постоянным, то Вы можете использовать :
    iAddress = "A2:A100"
    iResult = Evaluate("INDEX(" & iAddress & ",MODE(MATCH(" & iAddress & "," & iAddress & ",0)))")
    или
    iAddress = "A2:A100"
    iFormula = "INDEX(REF,MODE(MATCH(REF,REF,0)))"
    iFormula = Application.Substitute(iFormula, "REF", iAddress)
    'iFormula = Replace(iFormula, "REF", iAddress) 'MS Excel 2000

    iResult = Evaluate(iFormula)
    Примечание : Этот вариант также позволит получить нужный результат только при условии, что в указанном диапазоне нет пустых ячеек и ячеек, содержащих значение ошибки.
  • Ответ :

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

    Ура!!! Наконец-то скоро отпуск!!!!!!!!!

    убрать все проявления лишних эмоций, в примере это ! и в итоге оставить только :

    Ура! Наконец-то скоро отпуск!

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

    Вариант I.
  • Private Sub DeleteConsecutiveChar()
        Do Until Range("A1:C100").Find("!!", , xlValues, xlPart) Is Nothing
           Range("A1:C100").Replace "!!", "!", xlPart
        Loop
    End Sub
    Вариант II.
    Private Sub DeleteConsecutiveChar2()
        Do Until Application.CountIf(Range("A1:C100"), "*!!*") = 0
           Range("A1:C100").Replace "!!", "!", xlPart
        Loop
    End Sub

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

    Для того, чтобы в нужном диапазоне программно удалить условное форматирование достаточно использовать следующий синтаксис :
  • Range("A1:C100").FormatConditions.Delete
    Если же Вам нужно удалить вполне определённое условие, то укажите индекс(номер) ненужного условия (пример Условиe2)
    Range("A1:C100").FormatConditions(2).Delete
    Комментарий : Если к указанному диапазону будет применено только Условие1, то попытка удаления второго = несуществующего условия вызовет ошибку. Такая же ошибка возникнет, если в указанном диапазоне окажутся ячейки, к которым вообще не было применено условное форматирование или условия окажутся разными, например, если в диапазоне [A1:C100] Условие2 у ячейки A1 будет равно 1000, а Условие2 у ячейки С100 будет между 0 и 100

    Небольшой пример, который поможет определить, какое условие точно может быть удалено, прилагается :
    With Range("A1:C100").FormatConditions
         Select Case .Count
             Case -1: MsgBox "Вы можете удалить только все условия"
             Case 0: MsgBox "Удалять, собственно, и нечего"
             Case 1: MsgBox "Вы можете удалить только первое условие"
             Case 2: MsgBox "Вы можете удалить первое или второе условие"
             Case 3: MsgBox "Вы можете удалить любое из трёх условий"
         End Select
    End With
    Если нужно удалить условное форматирование во всех ячейках рабочего листа, к которым были применены такие же условия, как и у ячейки A1, то :
    Range("A1").SpecialCells(xlCellTypeSameFormatConditions).FormatConditions.Delete
    Если же Вам просто нужно получить ячейки с теми же условными форматами, что и ячейка-образец, то для этого можно воспользоваться следующим вариантом :
    Dim iCell As Range, iDiapazon As Range
    Set iCell = Range("A1") 'ячейка, которая служит образцом
    Set iDiapazon = iCell.SpecialCells(xlCellTypeSameFormatConditions)
    Если же "найти" аналогичное условное форматирование нужно не во всех ячейках рабочего листа, а в ячейках вполне определённого диапазона, то :
    Dim iCell As Range, iDiapazon As Range
    Set iCell = Range("A1") 'ячейка, которая служит образцом
    Set iDiapazon = Range("A1:C100") 'диапазон поиска аналогичных усл. форматов
    Set iDiapazon = Intersect(iCell.SpecialCells(xlCellTypeSameFormatConditions), iDiapazon)
    Комментарий :
  • Обратите внимание на то, что к ячейке A1 обязательно должно быть применено условное форматирование, иначе Вы получите ошибку, которой можно избежать, если добавить небольшую проверку (см. ниже)
  • Если рабочий лист защищён, то это также вызовет ошибку, если Вы не будете использовать этот [FAQ42]
  • If iCell.FormatConditions.Count > 0 Then
       'Необходимые действия
    Else
       'Продолжение невозможно
    End If

  • Ответ :

    Для того, чтобы подсчитать количество ячеек в диапазоне, удовлетворяющих заданному условию, и при этом, учитывать только видимые ячейки этого диапазона, достаточно использовать нижеопубликованный вариант, естественно, учитывая особенности .SpecialCells(xlVisible) :
  • Dim iDiapazon As Range, iArea As Range
    Set iDiapazon = [A2:C100]
    iCriteria$ = "Иванов" '"<>Иванов" '">0" '"<0"
    For Each iArea In iDiapazon.SpecialCells(xlVisible).Areas
        iCount& = iCount& + Application.CountIf(iArea, iCriteria$)
    Next
    MsgBox "Количество ячеек = " & iCount&

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

    Если Вам необходимо сразу после изменения данных (ввод, вставка скопированных/вырезаных данных) во всех ячейках, в которых произошли эти изменения, сделать Прописной первую букву в каждом слове текста, а все остальные буквы преобразовать в строчные, при этом игнорируя ячейки, содержащие формулы, то выберите наиболее подходящий вариант, и разместите его в модуле нужного рабочего листа [FAQ31]

    Вариант I.
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource As Range, iDiapazon As Range   
    
        If Target.Count = 1 Then
           If Not Target.HasFormula Then Set iSource = Target
           'Set iSource = IIf(Target.HasFormula, Nothing, Target)
        Else
           On Error Resume Next
           Set iSource = Target.SpecialCells(xlConstants, xlTextValues)
        End If
        
        If Not iSource Is Nothing Then
           Application.EnableEvents = False
           For Each iDiapazon In iSource.Areas       
               iDiapazon = Application.Proper(iDiapazon)
           Next
           Application.EnableEvents = True
        End If
    End Sub
    Вариант II.
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        With Application
             .ScreenUpdating = False
             .EnableEvents = False
             Dim iCell As Range
             For Each iCell In Target
                 If Not iCell.HasFormula Then _
                 iCell.Value = .Proper(iCell.Value)
                 'iCell = StrConv(CStr(iCell), vbProperCase)
             Next
             .EnableEvents = True
             .ScreenUpdating = True
        End With
    End Sub
    Примечание :
  • Если подобное преобразование должно происходить только в ячейках определённого диапазона, то смотрите следующий совет [FAQ99]
  • Если же преобразование необходимо производить во всех рабочих листах нужной рабочей книги, то используйте событие рабочей книги : Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
  • Ответ : Скачать пример Актуально для MS Excel 97-2003 (и старше)

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

    Разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31], указав свой диапазон и лимит времени.
  • Private iTimer As Date, iCollection As New Collection
    
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource1 As Range, iSource2 As Range, iCell As Range
        
        Set iSource1 = Range("A1,C1,F1") '[A1,C1,F1]
        Set iSource2 = Intersect(Target, iSource1)
       
        If iSource2 Is Nothing Then Exit Sub
        If iCollection.Count = 0 Then iTimer = Now 'Time
        
        On Error Resume Next
        For Each iCell In iSource2
            If Not IsEmpty(iCell) Then
               iCollection.Add "", iCell.Address
            Else
               iCollection.Remove iCell.Address
            End If
        Next
    
        If iCollection.Count = iSource1.Count Then
           If DateDiff("s", iTimer, Now) < 61 Then
              MsgBox "Успели за 60 секунд"
           Else
              MsgBox "НЕ Успели за 60 секунд"
           End If
           iTimer = 0: Set iCollection = Nothing
        End If
    End Sub
    Комментарий :
  • Таймер запускается после ввода(редактирования/копирования) данных в любую из ячеек указанного диапазона.
  • Удаление(очистка) данных игнорируется, но если такие действия должны учитываться, то просто оставьте только заполнение коллекции.
  • В примере лимит времени задан как 60секунд(1минута), но это не является обязательным, проще говоря, Вы можете изменить его.
  • Функция MsgBox используется только в качестве демонстрации.
  • Если диапазон, за которым мы установили слежку, насчитывает много ячеек или время, отведённое пользователю на ввод, невелико, то вычисление временного интервала, имеет смысл осуществлять перед работой с коллекцией.
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Если Вы хотите, чтобы после выделения необходимой ячейки и нажатия клавиши UP(стрелка вверх) дата(число), находящееся в ячейке увеличивалось на 1 день. A после нажатия клавиши DOWN(стрелка вниз) эта дата(число), соответственно, уменьшалась на 1 день, то :

    Разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        If Target.Address = "$A$1" Then
           Application.OnKey "{UP}", "PlusDay"
           Application.OnKey "{DOWN}", "MinusDay"
        Else
           Application.OnKey "{UP}"
           Application.OnKey "{DOWN}"
        End If
    End Sub
    A это код, в любом стандартном модуле :
    Private Sub PlusDay()
        Range("A1") = Range("A1") + 1
    End Sub
    
    Private Sub MinusDay()
        Range("A1") = Range("A1") - 1
    End Sub
    Если же мы явно укажем имя модуля, а также используем совет от Helen Toomik, то :
  • сможем разместить всё в одном модуле листа [FAQ31]
  • и об'единить макросы (плюс и минус) в один
  • Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        'Автор нижеприведённого способа передачи аргументов: Helen Toomik
        'http://www.markrowlinson.co.uk/articles.php?id=10
        If Target.Address = "$A$1" Then
           Application.OnKey "{UP}", "'" & CodeName & ".ChangeCell 1'"
           Application.OnKey "{DOWN}", "'" & CodeName & ".ChangeCell -1'"
        Else
           Application.OnKey "{UP}"
           Application.OnKey "{DOWN}"
        End If
    End Sub
    
    Public Sub ChangeCell(Operation#)
        Range("A1") = Range("A1") + Operation
    End Sub

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

    Если Вам необходимо сразу после изменения данных (ввод, вставка скопированных/вырезаных данных), которые произошли в одной единственной ячейке, найти слова с ошибками (с помощью проверки орфографии) и выделить их красным цветом, то разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Count > 1 Or Target.HasFormula Then Exit Sub
           
        Dim iCount%, iWord As Variant
        iCount = 1: Target.Font.Color = vbBlack
           
        'Application.Cursor = xlWait
        For Each iWord In Split(Target)
            If Not Application.CheckSpelling(iWord, , False) Then
               Target.Characters(iCount, Len(iWord)).Font.Color = vbRed
            End If
            iCount = iCount + Len(iWord) + 1
        Next
        'Application.Cursor = xlDefault
    End Sub
    Примечание :
  • Если выделение цветом должно происходить только в ячейках определённого диапазона, то смотрите следующий совет [FAQ99]
  • Если же автоматическую проверку орфографии необходимо организовать во всех рабочих листах нужной рабочей книги, то используйте событие рабочей книги : Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
  • Ответ :

    Если необходимо во всех рабочих листах активной книги - увеличить все числовые данные в диапазоне несмежных ячеек на указанный коэффициент, причём без перебора всех ячеек, то можно воспрользоваться любым вариантом :
  • Private Sub MultiplyNumbers()
        Dim iList As Worksheet, iSource As Range
        Dim iRefStyle&, iKoeff$: iKoeff = "1.75"
        iRefStyle = Application.ReferenceStyle
        
        For Each iList In ActiveWorkbook.Worksheets
            For Each iSource In iList.Range("C4:I8,C10:I46").Areas
                iSource = iList.Evaluate(iSource.Address(, , iRefStyle) & "*" & iKoeff)
            Next
        Next
    End Sub
    Private Sub MultiplyNumbers2()
        Dim iList As Worksheet, iSource As Range, iRefStyle&
        iRefStyle = Application.ReferenceStyle
        
        For Each iList In ActiveWorkbook.Worksheets
            For Each iSource In iList.[C4:I8,C10:I46].Areas
                iSource = Evaluate(iSource.Address(, , iRefStyle, True) & "*1.75")
            Next
        Next
    End Sub
    Комментарий : Не стоит забывать, что активная книга, диапазон (C4:I8,C10:I46) и увеличение на 75% используются только в качестве примера и могут быть изменены.
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Если Вам необходимо сразу после изменения данных (ввод, вставка скопированных/вырезаных данных) во всех ячейках, в которых произошли эти изменения, найти числа, меньше определённого, в данном примере, это 0,01 и заменить найденные числа на 0,01 то разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]

    Вариант I.
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        With Application
             If .CountIf(Target, "<0.01") > 0 Then
                .EnableEvents = False
                 Dim iCell As Range
                 For Each iCell In .Intersect(Target, Me.UsedRange)
                     If .IsNumber(iCell) = True Then
                        If iCell.Value < 0.01 Then iCell.Value = 0.01
                     End If
                 Next
                .EnableEvents = True
             End If
        End With
    End Sub
    Комментарий : Этот вариант не предназначен для обработки данных несмежных ячеек/диапазонов.

    Вариант II.
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        With Application
             If .Min(Target) < 0.01 Then
                .EnableEvents = False
                 Dim iCell As Range
                 For Each iCell In .Intersect(Target, Me.UsedRange)
                     If .CountIf(iCell, "<0.01") = 1 Then iCell = 0.01
                 Next
                .EnableEvents = True
             End If
        End With
    End Sub
    Комментарий : Второй вариант позволит решить поставленную задачу, если ввод данных будет осуществлён в несмежные ячейки/диапазоны, однако, его не следует применять, если хотя бы одна из ячеек, где произошли изменения, может содержать значение ошибки (константа или результат вычисления формулы)

    Примечание :
  • Если подобное преобразование должно происходить только в ячейках определённого диапазона, то смотрите следующий совет [FAQ99]
  • Если же преобразование необходимо производить во всех рабочих листах нужной рабочей книги, то используйте событие рабочей книги : Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
  • Ответ : Актуально для MS Excel 97-2003

    Если необходимо, чтобы после изменения данных (ввод, вставка скопированных/вырезаных данных) в ячейку [A1], новый текст был автоматически разделён по количеству символов и перенесён в следующие ячейки этого столбца, то разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
    Только не забудьте указать свою ячейку и максимально допустимое количество символов в ячейке. В примере это 50, т.е. сейчас, если в ячейку A1 ввести текст, длина которого будет, например, 103 символа, то в результате мы получим по 50 символов в ячейках A1, A2 и 3 символа в ячейке A3
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Address = "$A$1" Then
           Application.EnableEvents = False
           Dim iCount&, iText$: iText = Target
           For iCount = 1 To Len(iText) Step 50
               Target.Offset(iCount \ 50) = Mid(iText, iCount, 50)
           Next
           Application.EnableEvents = True
        End If
    End Sub

  • Ответ : Актуально для MS Excel 97-2003

    Если Вам необходимо, чтобы сразу после изменения данных (ввод, удаление, вставка скопированных/вырезаных данных) в столбце [A:A], была зафиксирована дата и время изменения, то разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Application.EnableEvents = False
        Intersect([A:A], Target.EntireRow).Value = Now 'Date
        Application.EnableEvents = True
    End Sub
    Если же Вы захотите добавить ещё и автоподбор ширины столбца, а также изменение формата ячеек на ДД.ММ.ГГГГ ч:мм:сс , то :
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Application.EnableEvents = False
        With Intersect([A:A], Target.EntireRow)
             .NumberFormat = "dd/mm/yy h:mm:ss"
             .Value = Now
             .Columns.AutoFit
        End With
        Application.EnableEvents = True
    End Sub
    И наконец, если удаление данных(*) не должно приводить к изменению даты и времени, а при копировании целых столбцов, необходимо учитывать используемый диапазон, то :
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Application.CountA(Target) = 0 Then Exit Sub
             
        Application.EnableEvents = False
        With Intersect([A:A], Target.EntireRow, UsedRange.EntireRow)
             .NumberFormat = "dd/mm/yy h:mm:ss"
             .Value = Now
             .Columns.AutoFit
        End With
        Application.EnableEvents = True
    End Sub
    Примечание : Не забывайте сохранять все необходимые изменения.
  • Ответ : Актуально для MS Excel 97, 2000, XP

    Если перед нами стоит следующая задача :
  • Отслеживать изменения данных (ввод, вставка скопированных/вырезаных данных) в столбце [C:C]
  • Aвтоматически воспроизводить системный звуковой файл notify.wav, если в диапазоне, где произошли изменения, будет найдено число больше 1000
  • или файл tada.wav, если такого числа не будет, то разместите нижеопубликованный код в модуле того рабочего листа [FAQ31], где необходимо устроить "слежку"

    Вариант I.
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource As Range
        Set iSource = Intersect(Target, [C:C])
        If Not iSource Is Nothing Then
           iPath$ = Environ("WinDir") & "\Media\"
           If Application.CountIf(iSource, ">1000") = 0 Then
              iFileName$ = iPath$ & "tada.wav"
           Else
              iFileName$ = iPath$ & "notify.wav"
           End If
           ExecuteExcel4Macro "SOUND.PLAY(,""" & iFileName$ & """)"
        End If
    End Sub
    Комментарий : Этот вариант не предназначен для обработки данных несмежных ячеек/диапазонов.

    Вариант II.
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource As Range, iDiapazon As Range
        Set iSource = Intersect(Target, [C:C])
        If Not iSource Is Nothing Then
           iPath$ = Environ("WinDir") & "\Media\"
           If Application.Max(iSource) > 1000 Then
              iFileName$ = iPath$ & "notify.wav"
           Else
              iFileName$ = iPath$ & "tada.wav"
           End If
           ExecuteExcel4Macro "SOUND.PLAY(,""" & iFileName$ & """)"
        End If
    End Sub
    Комментарий : Второй вариант позволит решить поставленную задачу, если ввод данных будет осуществлён в несмежные ячейки/диапазоны, однако, его не следует применять, если хотя бы одна из ячеек, где произошли изменения, может содержать значение ошибки (константа или результат вычисления формулы)

    Примечание :
  • Диапазон, критерий, а также звуковые файлы, разумеется, используются только в качестве примера и могут быть изменены.
  • Если следить за изменениями, необходимо во всех рабочих листах нужной рабочей книги, то используйте событие рабочей книги : Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
  • Ответ : Скачать пример Актуально для MS Excel 97-2003

    Если необходимо, чтобы после выделения нужной ячейки и ввода числа, происходило автоматическое суммирование чисел, которые были в этой ячейке до и после ввода, то разместите нижеопубликованный код в модуле того рабочего листа [FAQ31], где необходимо суммировать данные и, разумеется, не забудьте указать свою ячейку.
  • Private vData 'As Variant
     
    Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        If Not Intersect(Target, [A1]) Is Nothing Then
           If IsNumeric([A1]) Then vData = [A1]
        End If
    End Sub
     
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Not Intersect(Target, [A1]) Is Nothing Then
           Application.EnableEvents = False
           If IsNumeric([A1]) Then
              [A1] = [A1] + vData: vData = [A1]
           End If
           Application.EnableEvents = True
        End If
    End Sub
    Примечание : Для того, чтобы оставить возможность удаления числа (клавиша DELETE) - замените, например, IsNumeric на Application.IsNumber (см. пример), только учтите, что в этом случае макрос не будет суммировать текст '5 или "5"
    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

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