Private Sub Workbook_Open()

Dim ws As Worksheet, rn As Range, r As Long, cl As Long
Dim NG As Long, NR As Long, i As Long
Dim D As Date
Dim Rd As Collection

Set Rd = New Collection
For Each ws In ThisWorkbook.Worksheets
Set rn = ws.UsedRange
cl = rn.Rows(10).Find(what:="Наименование инструкции", LookIn:=xlValues, LookAt:=xlWhole).Column
rn.Interior.Pattern = xlNone
For r = 3 To rn.Rows.Count
If IsDate(rn(r, "E")) Then
D = rn(r, "E")
If D < Date Then
'срок истек
NR = NR + 1
rn.Rows(r).Interior.Color = vbRed
Rd.Add rn(r, cl)
ElseIf D - 100 < Date Then
'на подходе
NG = NG + 2
rn.Rows(r).Interior.Color = vbYellow
End If
End If
Next r
Next ws
If NG + NR > 0 Then
MsgBox "Просроченные инструкции выделены красным цветом, с истекающим сроком действия (через 100 дней) - желтым цветом."
End If
If Rd.Count > 0 Then
Unload frm_Предупреждение
Load frm_Предупреждение
With frm_Предупреждение
For i = 1 To Rd.Count
.lst_Инструкции.AddItem Rd(i)
Next i
.Show
End With
End If
If Rd.Count > 0 Then
Unload frm_Предупреждение1
Load frm_Предупреждение1
With frm_Предупреждение1
For i = 2 To Rd.Count
.lst_Инструкции.AddItem Rd(i)
Next i
.Show
End With
End If
End Sub