Ответ :
Для того, чтобы определить есть или нет заголовок(шапка) у таблицы,
можно использовать свойство 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, 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-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 или вставка пустой ячейки - не приводит к
удалению прежнего значения.
| | | | | | | | | | | | | | | | | | | | | | | | | | |
Вопросы - Синонимы
Воспроизведение любых опубликованных здесь материалов возможно только с
письменного разрешения автора :