Всем привет, есть книга и 30 листов. Есть код, записанный в "ЭтаКнига", он срабатывает каждый раз при изменении определенного диапазона ячеек в листе. Но нужно, чтоб он срабатывал на всех листах кроме первого, причем имя первого все время может меняться. Это главное условие. Макрос изменяет заливку ячеек в листах в диапазоне A5:Z60 при вводе 1, 0 или 0,5. Нужно игнорировать первый лист. Как? If Sh.Name = "Лист 1" Then Exit Sub очень просто конечно, но нужно универсальное, потому что имя первого листа всегда разное в разных файлах. Код: [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim KeyCells As Range Set KeyCells = Range("A5:Z60") 'задаем диапазон If Not Application.Intersect(KeyCells, Range(Target.Address)) _ Is Nothing Then 'если измененяется ячейка в диапазоне KeyCells, то красим в светло-желтый Application.ScreenUpdating = False: For Each Cell In KeyCells 'условие для каждой ячейки в диапазоне If Cell.Value = "0" Then Cell.Interior.ColorIndex = 36 'если равно 0, то красим в светло-желтый If Cell.Value = 0.5 Then Cell.Interior.ColorIndex = 36 'если равно 0,5, то красим в светло-желтый If Cell.Value = 1 Then Cell.Interior.ColorIndex = 36 'если равно 1, то красим в светло-желтый If Cell.Value = "" Then Cell.Interior.ColorIndex = 0 'если пустая, то красим в белый Next End If End Sub
[/vba]
Всем привет, есть книга и 30 листов. Есть код, записанный в "ЭтаКнига", он срабатывает каждый раз при изменении определенного диапазона ячеек в листе. Но нужно, чтоб он срабатывал на всех листах кроме первого, причем имя первого все время может меняться. Это главное условие. Макрос изменяет заливку ячеек в листах в диапазоне A5:Z60 при вводе 1, 0 или 0,5. Нужно игнорировать первый лист. Как? If Sh.Name = "Лист 1" Then Exit Sub очень просто конечно, но нужно универсальное, потому что имя первого листа всегда разное в разных файлах. Код: [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim KeyCells As Range Set KeyCells = Range("A5:Z60") 'задаем диапазон If Not Application.Intersect(KeyCells, Range(Target.Address)) _ Is Nothing Then 'если измененяется ячейка в диапазоне KeyCells, то красим в светло-желтый Application.ScreenUpdating = False: For Each Cell In KeyCells 'условие для каждой ячейки в диапазоне If Cell.Value = "0" Then Cell.Interior.ColorIndex = 36 'если равно 0, то красим в светло-желтый If Cell.Value = 0.5 Then Cell.Interior.ColorIndex = 36 'если равно 0,5, то красим в светло-желтый If Cell.Value = 1 Then Cell.Interior.ColorIndex = 36 'если равно 1, то красим в светло-желтый If Cell.Value = "" Then Cell.Interior.ColorIndex = 0 'если пустая, то красим в белый Next End If End Sub
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range) Dim KeyCells As Range, shRange As Range, rCell As Range Application.EnableEvents = False On Error Resume Next Set KeyCells = ActiveSheet.Range("A5:Z60") Set shRange = Sheets(1).UsedRange If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then If Application.Intersect(shRange, Range(Target.Address)) Is Nothing Then For Each rCell In KeyCells If rCell.Value = 0 Or rCell.Value = 0.5 Or rCell.Value = 1 _ Then rCell.Interior.ColorIndex = 36 If rCell.Value = "" Then rCell.Interior.ColorIndex = 0 Next End If End If Application.EnableEvents = True End Sub
[/vba]
Только, думаю, это можно без циклов организовать. Нужно подумать.
Подумал [vba]
Код
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range) Dim KeyCells As Range, shRange As Range On Error Resume Next Set KeyCells = ActiveSheet.Range("A5:Z60") Set shRange = Sheets(1).UsedRange If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then If Application.Intersect(shRange, Range(Target.Address)) Is Nothing Then If Target.Value = 0 Or Target.Value = 0.5 Or Target.Value = 1 _ Then Target.Interior.ColorIndex = 36 If Target.Value = "" Then Target.Interior.ColorIndex = 0 End If End If End Sub
[/vba]
А цикл можно повесить на открытие книги. Если необходимо не только при вводе, но и уже введенные значения закрасить.
Так, кажется, работает. [vba]
Код
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range) Dim KeyCells As Range, shRange As Range, rCell As Range Application.EnableEvents = False On Error Resume Next Set KeyCells = ActiveSheet.Range("A5:Z60") Set shRange = Sheets(1).UsedRange If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then If Application.Intersect(shRange, Range(Target.Address)) Is Nothing Then For Each rCell In KeyCells If rCell.Value = 0 Or rCell.Value = 0.5 Or rCell.Value = 1 _ Then rCell.Interior.ColorIndex = 36 If rCell.Value = "" Then rCell.Interior.ColorIndex = 0 Next End If End If Application.EnableEvents = True End Sub
[/vba]
Только, думаю, это можно без циклов организовать. Нужно подумать.
Подумал [vba]
Код
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range) Dim KeyCells As Range, shRange As Range On Error Resume Next Set KeyCells = ActiveSheet.Range("A5:Z60") Set shRange = Sheets(1).UsedRange If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then If Application.Intersect(shRange, Range(Target.Address)) Is Nothing Then If Target.Value = 0 Or Target.Value = 0.5 Or Target.Value = 1 _ Then Target.Interior.ColorIndex = 36 If Target.Value = "" Then Target.Interior.ColorIndex = 0 End If End If End Sub
[/vba]
А цикл можно повесить на открытие книги. Если необходимо не только при вводе, но и уже введенные значения закрасить.SkyPro
skypro1111@gmail.com
Сообщение отредактировал SkyPro - Среда, 14.08.2013, 12:38
всем спасибо, взял это решение добавил второй строчкой и все [vba]
Код
if Sh.Name = Sheets(1).Name then exit sub
[/vba] первый лист я имел ввиду по количеству первый, самый первый) слева) [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim ws As Worksheet If Sh.Name = Sheets(1).Name Then Exit Sub Dim KeyCells As Range Set KeyCells = Range("A5:Z60") If Not Application.Intersect(KeyCells, Range(Target.Address)) _ Is Nothing Then Application.ScreenUpdating = False: For Each Cell In KeyCells If Cell.Value = "0" Then Cell.Interior.ColorIndex = 36 If Cell.Value = 0.5 Then Cell.Interior.ColorIndex = 36 If Cell.Value = 1 Then Cell.Interior.ColorIndex = 36 If Cell.Value = "" Then Cell.Interior.ColorIndex = 0 Next End If End Sub
[/vba]
и еще, пожалуйста, помогите доработать код, голова уже не варит. Как присвоить всем ячейкам листов (кроме первого конечно же, он у нас особенный )формат ячеек общий? и как сделать, чтоб при вводе числа "5" в ячейку в указанном диапазоне A5:Z60 она заменялась на "0,5" и естественно окрашивалась, как уже сейчас работает ? заранее спасибо
всем спасибо, взял это решение добавил второй строчкой и все [vba]
Код
if Sh.Name = Sheets(1).Name then exit sub
[/vba] первый лист я имел ввиду по количеству первый, самый первый) слева) [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim ws As Worksheet If Sh.Name = Sheets(1).Name Then Exit Sub Dim KeyCells As Range Set KeyCells = Range("A5:Z60") If Not Application.Intersect(KeyCells, Range(Target.Address)) _ Is Nothing Then Application.ScreenUpdating = False: For Each Cell In KeyCells If Cell.Value = "0" Then Cell.Interior.ColorIndex = 36 If Cell.Value = 0.5 Then Cell.Interior.ColorIndex = 36 If Cell.Value = 1 Then Cell.Interior.ColorIndex = 36 If Cell.Value = "" Then Cell.Interior.ColorIndex = 0 Next End If End Sub
[/vba]
и еще, пожалуйста, помогите доработать код, голова уже не варит. Как присвоить всем ячейкам листов (кроме первого конечно же, он у нас особенный )формат ячеек общий? и как сделать, чтоб при вводе числа "5" в ячейку в указанном диапазоне A5:Z60 она заменялась на "0,5" и естественно окрашивалась, как уже сейчас работает ? заранее спасибоlakmus_x
Попробуйте вот такой макрос (без цикла - не меняет значения, которые были введены до запуска макроса): [vba]
Код
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range) Dim KeyCells As Range If ActiveSheet.Index = 1 Then Exit Sub Set KeyCells = ActiveSheet.Range("A5:Z60") If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then If Target.Value = 5 Then Target.Value = 0.5 If Target.Value = 0 Or Target.Value = 0.5 Or Target.Value = 1 _ Then Target.Interior.ColorIndex = 36 If Target.Value = "" Then Target.Interior.ColorIndex = 0 End If End Sub
[/vba]
И еще вот такой(с циклом перебора всех листов кроме первого), на открытие книги (перебирает все листы начиная с второго и меняет значения и форматирование): [vba]
Код
Private Sub Workbook_Open() Application.ScreenUpdating = False Application.EnableEvents = False Dim KeyCells As Range, rCell As Range, i& For i = 2 To Sheets.Count For Each rCell In Sheets(i).Range("A5:Z60") If rCell.Value = 5 Then rCell.Value = 0.5 ' эта часть заменит все 5 на 0.5 If rCell.Value = 0 Or rCell.Value = 0.5 Or rCell.Value = 1 _ Then rCell.Interior.ColorIndex = 36 If rCell.Value = "" Then rCell.Interior.ColorIndex = 0 Next Next Application.ScreenUpdating = True Application.EnableEvents = True End Sub
[/vba]
Изменить формат ячеек всех листов кроме первого на "общий": [vba]
Код
Sub generalF() Dim i& For i = 2 To Sheets.Count Cells.NumberFormat = "General" Next End Sub
[/vba]
Попробуйте вот такой макрос (без цикла - не меняет значения, которые были введены до запуска макроса): [vba]
Код
Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range) Dim KeyCells As Range If ActiveSheet.Index = 1 Then Exit Sub Set KeyCells = ActiveSheet.Range("A5:Z60") If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then If Target.Value = 5 Then Target.Value = 0.5 If Target.Value = 0 Or Target.Value = 0.5 Or Target.Value = 1 _ Then Target.Interior.ColorIndex = 36 If Target.Value = "" Then Target.Interior.ColorIndex = 0 End If End Sub
[/vba]
И еще вот такой(с циклом перебора всех листов кроме первого), на открытие книги (перебирает все листы начиная с второго и меняет значения и форматирование): [vba]
Код
Private Sub Workbook_Open() Application.ScreenUpdating = False Application.EnableEvents = False Dim KeyCells As Range, rCell As Range, i& For i = 2 To Sheets.Count For Each rCell In Sheets(i).Range("A5:Z60") If rCell.Value = 5 Then rCell.Value = 0.5 ' эта часть заменит все 5 на 0.5 If rCell.Value = 0 Or rCell.Value = 0.5 Or rCell.Value = 1 _ Then rCell.Interior.ColorIndex = 36 If rCell.Value = "" Then rCell.Interior.ColorIndex = 0 Next Next Application.ScreenUpdating = True Application.EnableEvents = True End Sub
[/vba]
Изменить формат ячеек всех листов кроме первого на "общий": [vba]
Код
Sub generalF() Dim i& For i = 2 To Sheets.Count Cells.NumberFormat = "General" Next End Sub
В первом все хорошо, нет перебора ячеек, что дает небольшую задержку при вводе, но при выделении ячеек и удалении значений (например надо выделить несколько значений и удалить значения и естественно чтоб очищалась заливка) то вылетает ошибка "Type mismatch" на строчку [vba]
Код
If Target.Value = 5 Then Target.Value = 0.5
[/vba] а этот макрос [vba]
Код
Sub generalF() Dim i& For i = 2 To Sheets.Count Cells.NumberFormat = "General" Next End Sub
[/vba] срабатывает на все листы, и на первый тоже. Но это не беда, вставил его сюда [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim ws As Worksheet 'делаем всем ячейкам на листе формат "общий" Dim i& If Sh.Name = Sheets(1).Name Then Exit Sub For i = 2 To Sheets.Count Cells.NumberFormat = "General" Next Dim KeyCells As Range If ActiveSheet.Index = 1 Then Exit Sub Set KeyCells = ActiveSheet.Range("A5:Z60") If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then If Target.Value = 5 Then Target.Value = 0.5 If Target.Value = 0 Or Target.Value = 0.5 Or Target.Value = 1 _ Then Target.Interior.ColorIndex = 36 If Target.Value = "" Then Target.Interior.ColorIndex = 0 End If End Sub
[/vba]
и отрабатывает свое дело хорошо) пока последний код меня полностью устраивает, кроме лишь той ошибки, которая вылетает при выделении нескольких значений и удалении значений
В первом все хорошо, нет перебора ячеек, что дает небольшую задержку при вводе, но при выделении ячеек и удалении значений (например надо выделить несколько значений и удалить значения и естественно чтоб очищалась заливка) то вылетает ошибка "Type mismatch" на строчку [vba]
Код
If Target.Value = 5 Then Target.Value = 0.5
[/vba] а этот макрос [vba]
Код
Sub generalF() Dim i& For i = 2 To Sheets.Count Cells.NumberFormat = "General" Next End Sub
[/vba] срабатывает на все листы, и на первый тоже. Но это не беда, вставил его сюда [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim ws As Worksheet 'делаем всем ячейкам на листе формат "общий" Dim i& If Sh.Name = Sheets(1).Name Then Exit Sub For i = 2 To Sheets.Count Cells.NumberFormat = "General" Next Dim KeyCells As Range If ActiveSheet.Index = 1 Then Exit Sub Set KeyCells = ActiveSheet.Range("A5:Z60") If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then If Target.Value = 5 Then Target.Value = 0.5 If Target.Value = 0 Or Target.Value = 0.5 Or Target.Value = 1 _ Then Target.Interior.ColorIndex = 36 If Target.Value = "" Then Target.Interior.ColorIndex = 0 End If End Sub
[/vba]
и отрабатывает свое дело хорошо) пока последний код меня полностью устраивает, кроме лишь той ошибки, которая вылетает при выделении нескольких значений и удалении значенийlakmus_x
lakmus_x, а Вы белиберды понаписали. Попробуйте: [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim c As Range If Sh.Index = 1 Then Exit Sub Sh.UsedRange.NumberFormat = "General" If Not Application.Intersect(Sh.[A5:Z60], Target) Is Nothing Then For Each c In Sh.[A5:Z60].Cells Select Case c Case 5: c = 0.5 Case "": c.Interior.ColorIndex = xlNone Case 0, 0.5, 1: c.Interior.ColorIndex = 36 End Select Next End If End Sub
[/vba]
lakmus_x, а Вы белиберды понаписали. Попробуйте: [vba]
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim c As Range If Sh.Index = 1 Then Exit Sub Sh.UsedRange.NumberFormat = "General" If Not Application.Intersect(Sh.[A5:Z60], Target) Is Nothing Then For Each c In Sh.[A5:Z60].Cells Select Case c Case 5: c = 0.5 Case "": c.Interior.ColorIndex = xlNone Case 0, 0.5, 1: c.Interior.ColorIndex = 36 End Select Next End If End Sub
спасибо, действительно, "когда условий становится слишком много, if else.... if теряет свою привлекательность, для этого есть select case" сейчас остается лишь одна недоработка, это при выделении нескольких ячеек и удалении нужно чтоб и очищалась заливка
спасибо, действительно, "когда условий становится слишком много, if else.... if теряет свою привлекательность, для этого есть select case" сейчас остается лишь одна недоработка, это при выделении нескольких ячеек и удалении нужно чтоб и очищалась заливкаlakmus_x
Сообщение отредактировал lakmus_x - Четверг, 15.08.2013, 10:27
сейчас остается лишь одна недоработка, это при выделении нескольких ячеек и удалении нужно чтоб и очищалась заливка
Выше вам предоставили макрос ,который работает как надо. А если дорабатывать мой, то первое, что приходит в голову это на событие открытия книги повесить макрос с циклом. Да и [vba]
Код
Sh.UsedRange.NumberFormat = "General"
[/vba] Я бы запускал единоразово при открытии или закрытии (а то каждый раз менять форматы не комильфо).
сейчас остается лишь одна недоработка, это при выделении нескольких ячеек и удалении нужно чтоб и очищалась заливка
Выше вам предоставили макрос ,который работает как надо. А если дорабатывать мой, то первое, что приходит в голову это на событие открытия книги повесить макрос с циклом. Да и [vba]
Код
Sh.UsedRange.NumberFormat = "General"
[/vba] Я бы запускал единоразово при открытии или закрытии (а то каждый раз менять форматы не комильфо).SkyPro
skypro1111@gmail.com
Сообщение отредактировал SkyPro - Четверг, 15.08.2013, 10:24
да, мне тоже это не понравилось, поэтому убрал это отдельно при выделении и чтоб менял лишь у выделенной ячейки [vba]
Код
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Index = 1 Then Exit Sub Selection.NumberFormat = "General" End Sub
[/vba]
сейчас код KuklP-а уже другой ,сначала там не было [vba]
Код
For Each c In Sh.[A5:Z60].Cells
[/vba]
да, мне тоже это не понравилось, поэтому убрал это отдельно при выделении и чтоб менял лишь у выделенной ячейки [vba]
Код
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Index = 1 Then Exit Sub Selection.NumberFormat = "General" End Sub
[/vba]
сейчас код KuklP-а уже другой ,сначала там не было [vba]
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Index = 1 Then Exit Sub Selection.NumberFormat = "General" End Sub
[/vba] почему же он чаще запускается, чем "Target.NumberFormat = "General"" в вашем случае он каждый раз всем будет вставлять формат общий при изменении ячеек, а при Workbook_SheetSelectionChange лишь одной выделенной ячейке (или у нескольких, если выделить), мне лишь важно чтоб у 1, 0 и 0,5 был правильный формат
добавил исключение первого листа [vba]
Код
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Index = 1 Then Exit Sub Selection.NumberFormat = "General" End Sub
[/vba] почему же он чаще запускается, чем "Target.NumberFormat = "General"" в вашем случае он каждый раз всем будет вставлять формат общий при изменении ячеек, а при Workbook_SheetSelectionChange лишь одной выделенной ячейке (или у нескольких, если выделить), мне лишь важно чтоб у 1, 0 и 0,5 был правильный форматlakmus_x
Сообщение отредактировал lakmus_x - Четверг, 15.08.2013, 10:54
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
