Microsoft Excel:

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


Rambler's Top100


Counter CO.KZ


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

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


    Microsoft Excel 2007(и старше)

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

    Вариант I.
    Dim iListObject As ListObject
    Set iListObject = Worksheets(1).ListObjects(1)
    
    If iListObject.ShowHeaders = True Then
       MsgBox "Есть строка заголовка", , ""
    Else
       MsgBox "Строка заголовка изволит отсутствовать", , ""
    End If
    Вариант II.
    Dim iListObject As ListObject
    Set iListObject = Worksheets(1).ListObjects(1)
    
    If Not iListObject.HeaderRowRange Is Nothing Then
       MsgBox "Есть строка заголовка", , iListObject.Name
    Else
       MsgBox "Строка заголовка изволит отсутствовать", , iListObject.Name
    End If
    Разумеется, использование об'ектной переменной не носит обязательного характера.
  • Ответ : Актуально для MS Excel 2003 (и старше)

    Для того, чтобы получить массив, содержащий все значения заголовка(шапки) "умной" таблицы(списка), можно использовать любой из трёх нижеопубликованных способов. Для сокращения места, все варианты наличествуют в одном листинге(коде)
  • Dim iListObject As ListObject
    Set iListObject = Worksheets(1).ListObjects(1)
        
    iArr1 = iListObject.HeaderRowRange.Value
    iArr2 = Range(iListObject.Name & "[#Headers]")
    iArr3 = Evaluate(iListObject.Name & "[#Headers]")
    Если же имя "умной" таблицы(списка) является константой и уже нам известно, то достаточно использовать :
    iArr1 = [Таблица1[#Headers]]
    iArr2 = Range("Таблица1[#Headers]")
    iArr3 = Evaluate("Таблица1[#Headers]")
    
    iArr4 = Range("Таблица1").ListObject.HeaderRowRange
    Комментарий : Если заголовки будут изволить отсутствовать, то при использовании об'екта Range возникнет ошибка 1004 ( iArr2 ) и 91 ( iArr4 )
    A в остальных случаях, мы получим переменную, содержащую значение ошибки (Error 2023) Впрочем, мы можем просто предварительно проверить наличие/отсутствие строк заголовка [FAQ618] и в случае их отсутствия, избежать ненужных телодвижений, проще говоря, не пытаться получить данные, которых нет.
  • Ответ :

    Для того, чтобы узнать номер последней скрытой строки, причём без цикла, можно использовать нижеопубликованный вариант, естественно, учитывая особенности .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
    Примечание : Обратите внимание на то, что данный способ не анализирует разделяемый текст, поэтому всегда есть вероятность, что слово в тексте, будет разделено. Если сие неприемлемо, то можно посмотреть следующий FAQ, где текст разбивается по ширине столбца.
  • Ответ : Актуально для MS Excel 97-2003

    Если необходимо, чтобы после изменения текста (ввод, вставка скопированного/вырезаного текста) в ячейку [A1], новый текст был автоматически разделён, исходя из ширины столбца и перенесён в следующие ячейки этого столбца, то разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Address <> "$A$1" Then Exit Sub
        
        Application.EnableEvents = False
        Application.DisplayAlerts = False
        On Error Resume Next
        Target.Justify
        Application.DisplayAlerts = True
        Application.EnableEvents = True
    End Sub
    Комментарий : Имейте ввиду, что :
  • числа и формулы не могут быть разделены по нескольким ячейкам.
  • в версии Excel 97 использование метода Justify не приводит к "повторной" генерации события Worksheet_Change, поэтому в этой версии, вполне можно обойтись без блокировки событий.
  • Ответ : Актуально для MS Excel 97-2007

    Если Вам необходимо, чтобы после ввода, изменения, или вставки скопированного/вырезаного текста (не являющегося результатом вычисления формул) в любую из ячеек диапазона [A1:C10], во всех остальных ячейках, повторы(дубли) были автоматически удалены, то разместите нижеопубликованный код в модуле нужного рабочего листа [FAQ31]
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Not Intersect(Target, [A1:C10]) Is Nothing Then
           iText = Target.Value
           If VarType(iText) = vbString Then
              Application.EnableEvents = False
              [A1:C10].Replace iText, "", xlWhole
              Target.Value = iText
              Application.EnableEvents = True
           End If
        End If
    End Sub
    Комментарий : При вводе данных, помните, что данный пример предназначен создан для удаления повторов(дублей) текста, а стало быть он не предназначен для работы с числами, датами, логическими значениями, а также значениями ошибок. Кроме того, здесь будут игнорированы любые изменения, которые произошли в более чем одной ячейке указанного диапазона. Проще говоря, если Вы изменяете значения нескольких ячеек, к примеру, A1 и B1 , то здесь необходимо добавить цикл, т.е.
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource As Range, iCell As Range, iText
        Set iSource = Intersect(Target, Range("A1:C10"))
        
        If iSource Is Nothing Then Exit Sub
        
        Application.EnableEvents = False
        For Each iCell In iSource
           iText = iCell.Value
           If Application.IsText(iText) = True Then
              Range("A1:C10").Replace iText, "", xlWhole
              iCell.Value = iText
           End If
        Next
        Application.EnableEvents = True
    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-2007

    Если перед нами стоит следующая задача :
  • Отслеживать изменения данных (ввод, вставка скопированных/вырезаных данных) в столбце [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-2007

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

    Вариант I.
  • Private Sub Worksheet_Calculate()    
        If Application.CountIf([A:A], ">1000") > 0 Then
           iPath$ = Environ("WinDir") & "\Media\"
           iFileName$ = iPath$ & "tada.wav"
           ExecuteExcel4Macro "SOUND.PLAY(,""" & iFileName$ & """)"
        End If
    End Sub
    Комментарий : Этот вариант не предназначен для обработки данных несмежных ячеек/диапазонов.

    Вариант II.
    Private Sub Worksheet_Calculate()
        If Application.Max([A:A]) > 1000 Then
           iPath$ = Environ("WinDir") & "\Media\"
           iFileName$ = iPath$ & "tada.wav"
           ExecuteExcel4Macro "SOUND.PLAY(,""" & iFileName$ & """)"
        End If
    End Sub
    Комментарий : Второй вариант позволит решить поставленную задачу, если пересчёт фомул, может произойти в несмежных ячейках/ диапазонах, однако, его не следует применять, если хотя бы одна из ячеек, указанного диапазона, будет содержать значение ошибки (константа или результат вычисления формулы)

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

    Если необходимо, чтобы после выделения нужной ячейки и ввода числа, происходило автоматическое суммирование чисел, которые были в этой ячейке до и после ввода, то разместите нижеопубликованный код в модуле того рабочего листа [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"

    Комментарий : Если же в ячейке был предварительно установлен текстовый формат, то при использовании данного макроса, Вы получите не суммирование, а конкатенацию (об'единение)
    Т.e. результат [A1] = "3" + "7" будет не 10, а 37
    Чтобы этого не происходило, достаточно в событии Change использовать, например,
    [A1] = [A1] + CDbl(vData) 'Target = Target + CDbl(vData)
    
    или
    [A1] = Application.Sum([A1].Value, vData)
    Если же Вы планируете осуществить подобное суммирование в ячейках определённого диапазона, то используйте нижеопубликованный код, только учтите, что накопление(суммирование) происходит только, если изменение произошло в одной ячейке. И обратите внимание на то, что отмена последнего действия пользователя, который ввёл данные, отличные от числа, не является обязательным действием.
    Private vData
     
    Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        If Target.Count > 1 Then Exit Sub
        If Not Intersect(Target, [A1:A100]) Is Nothing Then
           If IsNumeric(Target) Then vData = Target
        End If
    End Sub
     
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Count > 1 Then Exit Sub
        If Not Intersect(Target, [A1:A100]) Is Nothing Then
           Application.EnableEvents = False
           If IsNumeric(Target) Then
              Target = Target + vData
           Else
              Application.Undo 'Отмена (необязательно)
           End If
           Application.EnableEvents = True
        End If
    End Sub

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

    Если необходимо, чтобы после выделения нужного диапазона ячеек и ввода числа (или вставки заранее скопированных данных), происходило автоматическое суммирование чисел, которые были в этих ячейках до и после ввода(вставки), то разместите нижеопубликованный код в модуле того рабочего листа [FAQ31], где необходимо суммировать данные. И, разумеется, не забудьте указать свой диапазон ячеек. Обратите внимание на то что, в примере диапазон начинается с первого столбца/строки, поэтому "смещение" по столбцам/строкам в примере отсутствует.
  • Private vData 'As Variant
    
    Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        If Not Intersect(Target, [A1:B100]) _
        Is Nothing Then vData = [A1:B100].Value
    End Sub
    
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iRow&, iColumn&, tmp 'As Variant
        Dim iSource As Range, iCell As Range
        Set iSource = Intersect(Target, [A1:B100])
        If iSource Is Nothing Then Exit Sub
    
        Application.EnableEvents = False
        For Each iCell In iSource      
            tmp = iCell.Value
            iRow = iCell.Row
            iColumn = iCell.Column
            Select Case True
                Case IsEmpty(tmp)
                   vData(iRow, iColumn) = Empty
                Case IsNumeric(tmp) And IsNumeric(vData(iRow, iColumn))
                   vData(iRow, iColumn) = vData(iRow, iColumn) + CDbl(tmp)
                Case IsNumeric(tmp) 'Case Else
                   vData(iRow, iColumn) = tmp
            End Select
        Next
        [A1:B100].Value = vData
        Application.EnableEvents = True
    End Subb
    Примечание : Обратите внимание на то, что использование клавиши DELETE или вставка пустой ячейки - приводит к удалению прежнего значения. Если же Вам нужно разделить эти два действия, т.е. после вставки пустой ячейки - не удалять старое значение, то используйте предыдущий совет [FAQ863]
  • Ответ : Актуально для MS Excel 97-2007

    Если необходимо, чтобы после выделения нужного диапазона ячеек и ввода числа (или вставки заранее скопированных данных), происходило автоматическое суммирование чисел, которые были в этих ячейках до и после ввода(вставки), то разместите нижеопубликованный код, согласно инструкции, в трёх различных модулях. И, разумеется, не забудьте указать свой диапазон, причём в этом примере, допускается использование диапазона несмежных ячеек.

    Модуль книги ThisWorkbook(ЭтаКнига)
  • Private Sub Workbook_Open()
        Set dArchive = CreateObject("Scripting.Dictionary")
    End Sub
    Модуль листа, в котором нам необходимо осуществить суммирование
    Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
        Dim iSource As Range, iCell As Range
        Set iSource = Intersect(Target, [A1:A100,C1,M7])
        If iSource Is Nothing Then Exit Sub
        
        For Each iCell In iSource
            If IsNumeric(iCell) Then dArchive(iCell.Address) = iCell
        Next
    End Sub
     
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource As Range, iCell As Range, iAddress$
        Set iSource = Intersect(Target, [A1:A100,C1,M7])
        If iSource Is Nothing Then Exit Sub
        
        Application.EnableEvents = False
        For Each iCell In iSource
            If IsNumeric(iCell) Then
               iAddress = iCell.Address
               dArchive(iAddress) = dArchive(iAddress) + iCell 'CDbl(iCell)
               iCell = dArchive(iAddress)
            End If
        Next
        Application.EnableEvents = True
    End Sub
    Любой стандартный модуль
    Public vData, dArchive As Object
    Примечание : Обратите внимание на то, что использование клавиши DELETE или вставка пустой ячейки - не приводит к удалению прежнего значения.


    Вопросы - Синонимы
    Как сделать так, чтобы в определённом диапазоне был только уникальный текст, т.е. чтобы сразу после ввода текста, все остальные повторы(дубли) этого текста, автоматически удалялись ?

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

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