Private Sub Worksheet_Change(ByVal Target As RANGE)
    If Not Intersect(Target, Me.RANGE("C1:C4")) Is Nothing Then
        Application.EnableEvents = False  ' Избежать рекурсии
        Call UpdateLinkedCells(Target)
    
        Application.EnableEvents = True
    End If
End Sub

Sub UpdateLinkedCells(Target As RANGE)
    Dim wsGEN As Worksheet
    Dim wsDB As Worksheet
    Dim lastRowDB As Long
    Dim r As Long
    Dim found As Boolean
    Dim currentC2 As String
    
    Set wsGEN = ThisWorkbook.Sheets("Device_LIST_GENERATION")
    Set wsDB = ThisWorkbook.Sheets("DB_C0")
    lastRowDB = wsDB.Cells(wsDB.Rows.Count, "A").End(xlUp).row
    found = False
    
    ' Сохраняем текущее значение C2 перед изменением
    currentC2 = UCase(Trim(wsGEN.RANGE("C2").Value))
    
    If Target.Address = "$C$2" Then  ' TAG_RELEVANT_EQUIPMENT changed
        Dim selRelevant As String
        selRelevant = UCase(Trim(wsGEN.RANGE("C2").Value))
        For r = 2 To lastRowDB
            If UCase(Trim(wsDB.Cells(r, 3).Value)) = selRelevant Then  ' Column C in DB_C0
                wsGEN.RANGE("C3").Value = wsDB.Cells(r, 5).Value  ' Discipline to C3
                wsGEN.RANGE("C4").Value = wsDB.Cells(r, 2).Value  ' TAG_ITEM_NUMBER_CCMS to C4
                found = True
                Exit For
            End If
        Next r
        
    ElseIf Target.Address = "$C$3" Then  ' Discipline changed
        Dim selDisc As String
        selDisc = UCase(Trim(wsGEN.RANGE("C3").Value))
        
        ' Сначала ищем запись с текущим C2 и новым значением Discipline
        For r = 2 To lastRowDB
            If UCase(Trim(wsDB.Cells(r, 3).Value)) = currentC2 And _
               UCase(Trim(wsDB.Cells(r, 5).Value)) = selDisc Then
                wsGEN.RANGE("C4").Value = wsDB.Cells(r, 2).Value  ' Обновляем только C4
                found = True
                Exit For
            End If
        Next r
        
        ' Если не нашли комбинацию C2 + новая дисциплина, тогда меняем C2
        If Not found Then
            For r = 2 To lastRowDB
                If UCase(Trim(wsDB.Cells(r, 5).Value)) = selDisc Then  ' Column E
                    wsGEN.RANGE("C2").Value = wsDB.Cells(r, 3).Value  ' TAG_RELEVANT to C2
                    wsGEN.RANGE("C4").Value = wsDB.Cells(r, 2).Value  ' TAG_ITEM to C4
                    found = True
                    Exit For
                End If
            Next r
        End If
        
    ElseIf Target.Address = "$C$4" Then  ' TAG_ITEM_NUMBER_CCMS changed
        Dim selTag As String
        selTag = UCase(Trim(wsGEN.RANGE("C4").Value))
        For r = 2 To lastRowDB
            If UCase(Trim(wsDB.Cells(r, 2).Value)) = selTag Then  ' Column B
                wsGEN.RANGE("C2").Value = wsDB.Cells(r, 3).Value  ' TAG_RELEVANT to C2
                wsGEN.RANGE("C3").Value = wsDB.Cells(r, 5).Value  ' Discipline to C3
                found = True
                Exit For
            End If
        Next r
    End If
    
    ' Если не найдено, можно добавить логику очистки, например:
    ' If Not found Then wsGen.Range("C2:C4").ClearContents
End Sub

Option Explicit

Public Function Test(ByVal foo As Range) As Variant
    Dim pReg As Object, sXml As String, pItems As Object
    Dim vOut() As Variant, i As Long

    If foo.Count = 1 Then
        Set pReg = CreateObject("VBScript.RegExp")
        pReg.Global = True: pReg.IgnoreCase = True
        pReg.Pattern = "<Font[^>""]*?(?:html:Color=""(#[A-F\d]+)"")?>(.+?)</FONT>"
        sXml = foo.Value(xlRangeValueXMLSpreadsheet)
        Set pItems = pReg.Execute(sXml)
        ReDim vOut(0 To pItems.Count - 1, 1 To 2)
        For i = 0 To pItems.Count - 1
            vOut(i, 1) = pItems(i).SubMatches(1)
            vOut(i, 2) = pItems(i).SubMatches(0)
            If IsEmpty(vOut(i, 2)) Then vOut(i, 2) = "#000000"
        Next
        Test = vOut
    End If
End Function

Public Function OneColor(Cell As Range)
    OneColor = Cell.Font.Color
End Function

Public Function CountZZZ(Area As Range) As Double
Dim rCell As Range
Dim Unique As New Collection
On Error Resume Next
    
    For Each rCell In Area
    If Not IsEmpty(rCell) And Not rCell.EntireRow.Hidden Then Unique.Add rCell.Value, CStr(rCell.Value)
 Next
    
CountZZZ = Unique.Count
End Function

Public Function CountZZZ(Area As Range) As Double
Dim rCell As Range
Dim Unique As New Collection
On Error Resume Next
    
    For Each rCell In Area
        If Not IsEmpty(rCell) Then Unique.Add rCell.Value, CStr(rCell.Value)
    Next
    
CountZZZ = Unique.Count
End Function

Set lst = frm.Document.getElementsByName("SelectReport")(0)

Sub Attempt()
Dim ie As Object
Dim frm As Object
Dim frm1 As Object
Dim lst As Object
    Set ie = CreateObject("internetexplorer.application")
    ie.Visible = True
    'открываем сайт
    ie.navigate "http://ets.aeso.ca/ets_web/docroot/Market/Reports/HistoricalReportsStart.html"
    'ждёмс
    Do
    Loop Until Not (ie.Busy)
    Application.Wait Now + TimeValue("00:00:02")
'выбираем рамку (вот может тут уже неправильно присвоено)
Set frm1 = ie.document.Frames
Set frm = frm1("report_nav")
                
' может проблема здесь
Set lst = frm.document.getElementsByTagName("SelectReport")
'на вэлью появляется ошибка
lst.Value = "Market/Reports/PublicSummaryAllReportServlet"
Set lst = frm.Function("populateReportType(document.reportForm, getCurrReportObj())")
lst
    
    Set ie = Nothing
    Set frm = Nothing
    Set frm1 = Nothing
    Set lst = Nothing
    
End Sub

 Option Explicit[P] 
 Sub WBk1M()
 Dim x, wb As Workbook
 For Each x In Workbooks
   If x.Name = "Книга2.xlsm" Then Exit For
 Next
 If IsEmpty(x) Then Workbooks.Open ThisWorkbook.Path & "\Книга2.xlsm"
 Application.Run "Книга2.xlsm!module1.WBk2M"
 End Sub
 Option Explicit
 
 Sub WBk2M()
 Dim x
 For Each x In Workbooks
   If x.Name = "Книга1.xlsm" Then x.Close False: Exit For
 Next
 
 'после предыдущей строчке макрос перестаёт работать...
 MsgBox "Появись, появись...!"
 ' это сообщение не появляется, через 1 книгу..
 End Sub