Здравствуйте! Нужна помощь в написании макроса. вкратце - при заполнении шаблона нужна проверка пустых ячеек в строке и что бы выдавал всплывающее окно с подсказкой какие ячейки нужно заполнить в шаблоне я описала подробнее задачу Заранее благодарю!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
x = ""
If Cells(Target.Row - 1, 6) = "Вакансия NEW" Then
For i = 2 To 22
Select Case i
Case i = 2 To 10 And Cells(Target.Row - 1, i) = "", _
14 To 20 And Cells(Target.Row - 1, i) = "", _
22 And Cells(Target.Row - 1, i) = "": x = x & Cells(1, i) & Chr(10)
End Select
Next
MsgBox "Не заполнены обязательные поля:" & Chr(10) & x
End
End If
End Sub
Sub checkExplicitCells()
Dim headersRn As Range, rrow As Range
Dim explicitCellsMaskRn As Range, curRowBlankRn As Range, curRowExplicitMaskRn
With ActiveSheet
' Диапазон заголовков. Отсюда будем брать названия и смотрим цвет ячеек. Желтые - обязательные
Set headersRn = Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
' Определяем обязательные ячейки
Set explicitCellsMaskRn = Nothing
' Пробегаемся по всем заголовкам и добавляем желтые в диапазон explicitCellsMaskRn
For i = 1 To headersRn.Columns.Count
If headersRn.Cells(1, i).Interior.Color = vbYellow Then
If explicitCellsMaskRn Is Nothing Then
Set explicitCellsMaskRn = .Cells(1, i)
Else
Set explicitCellsMaskRn = Union(explicitCellsMaskRn, .Cells(1, i))
End If
End If
Next i
' Диапазон с типом (Вакансия) - с F3 и вниз до упора
Set vacancyNewRange = Range(.Range("F3"), .Range("F3").End(xlDown))
' Пробегаемся вниз по диапазону, ищем Вакансия NEW
For Each rrow In vacancyNewRange.Rows
If rrow.Value = "Вакансия NEW" Then
' Сдвигаем диапазон explicitCellsMaskRn на текущую строку
Set curRowExplicitMaskRn = explicitCellsMaskRn.Offset(rrow.Row - 1, 0)
' Если кол-во непустых ячеек в диапазоне меньше чем общее количество ячеек - значит что-то незаполнено
If curRowExplicitMaskRn.Cells.Count - WorksheetFunction.CountA(curRowExplicitMaskRn) > 0 Then
' Смотрим на каждую ячейку, пустые заносим в диапазон curRowBlankRn
For Each ccell In curRowExplicitMaskRn.Cells
If IsEmpty(ccell) Then
If curRowBlankRn Is Nothing Then
Set curRowBlankRn = ccell
Else
Set curRowBlankRn = Union(curRowBlankRn, ccell)
End If
txt = txt & IIf(txt <> "", ", ", "") & vbNewLine & headersRn.Cells(1, ccell.Column).Value
End If
Next ccell
' Красим curRowBlankRn в желтый и выделяем его
curRowBlankRn.Interior.Color = vbYellow
curRowBlankRn.Select
' Выводим сообщение
MsgBox "Заполните пол" & IIf(curRowBlankRn.Cells.Count = 1, "е:", "я ") & txt, vbExclamation
Set curRowBlankRn = Nothing
txt = ""
End If
End If
Next rrow
End With
End Sub
' Диапазон заголовков. Отсюда будем брать названия и смотрим цвет ячеек. Желтые - обязательные
Set headersRn = Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
на
' Диапазон заголовков. Отсюда будем брать названия и смотрим цвет ячеек. Желтые - обязательные
Set headersRn = Range(.Cells(4, 1), .Cells(4, .Columns.Count).End(xlToLeft))
и тут:
Код
' Диапазон с типом (Вакансия) - с F3 и вниз до упора
Set vacancyNewRange = Range(.Range("F3"), .Range("F3").End(xlDown))
на
' Диапазон с типом (Вакансия) - с F3 и вниз до упора
Set vacancyNewRange = Range(.Range("F4"), .Range("F4").End(xlDown))
Tolstak, спасибо! ваш макрос можно использовать для любого файла? Изменила в нем ячейки как написали, но что то он не работает... Что мне проверить еще?
Sub checkExplicitCells()
Dim headersRn As Range, rrow As Range, explicitCellsMaskRn As Range, curRowBlankRn As Range, curRowExplicitMaskRn
With ActiveSheet
' Диапазон заголовков. Отсюда будем брать названия и смотрим цвет ячеек. Желтые - обязательные
Set headersRn = Range(.Cells(4, 1), .Cells(4, .Columns.Count).End(xlToLeft))
' Диапазон с типом (Вакансия) - с F5 и вниз до упора
Set vacancyNewRange = Range(.Range("F6"), .Range("F6").End(xlDown))
' Определяем обязательные ячейки
Set explicitCellsMaskRn = Nothing
' Пробегаемся по всем заголовкам и добавляем желтые в диапазон explicitCellsMaskRn
For i = 1 To headersRn.Columns.Count
If headersRn.Cells(1, i).Interior.Color = vbYellow Then
If explicitCellsMaskRn Is Nothing Then
Set explicitCellsMaskRn = headersRn.Cells(1, i)
Else
Set explicitCellsMaskRn = Union(explicitCellsMaskRn, headersRn.Cells(1, i))
End If
End If
Next i
' Пробегаемся вниз по диапазону, ищем Вакансия NEW
For Each rrow In vacancyNewRange.Rows
If rrow.Value = "Вакансия NEW" Then
' Сдвигаем диапазон explicitCellsMaskRn на текущую строку
Set curRowExplicitMaskRn = explicitCellsMaskRn.Offset(rrow.Row - explicitCellsMaskRn.Row, 0)
' Если кол-во непустых ячеек в диапазоне меньше чем общее количество ячеек - значит что-то незаполнено
If curRowExplicitMaskRn.Cells.Count - WorksheetFunction.CountA(curRowExplicitMaskRn) > 0 Then
' Смотрим на каждую ячейку, пустые заносим в диапазон curRowBlankRn
For Each ccell In curRowExplicitMaskRn.Cells
If IsEmpty(ccell) Then
If curRowBlankRn Is Nothing Then
Set curRowBlankRn = ccell
Else
Set curRowBlankRn = Union(curRowBlankRn, ccell)
End If
txt = txt & IIf(txt <> "", ", ", "") & vbNewLine & headersRn.Cells(1, ccell.Column).Areas(1).Cells(1).Value
End If
Next ccell
' Красим curRowBlankRn в желтый и выделяем его
curRowBlankRn.Interior.Color = vbYellow
curRowBlankRn.Select
' Выводим сообщение
MsgBox "Заполните пол" & IIf(curRowBlankRn.Cells.Count = 1, "е:", "я ") & txt, vbExclamation
Set curRowBlankRn = Nothing
txt = ""
End If
End If
Next rrow
End With
End Sub
Tolstak, спасибо Вам большое! Все работает. Еще небольшое уточнение-если хочу изменить цвет с желтого на светло-зеленый, где искать обозначение цветов? Прям писать по-английски как есть?
Sub cellsColors()
For Each ccell In Selection.Cells
ccell.Value = ccell.Interior.Color
Next ccell
End Sub
Можно использовать предопределенные цвета, вроде VbYellow (как в примере) - список тут. Или скопируйте ячейку, выполните макрос, и подставьте в код вместо VbYellow номер цвета из ячейки.