Выбрать ячейки из столбца выделенные цветом и копировать

[PetyaVova]

Существует итоговый файл в который ежемесячно копируется на новый лист
итоговая информация по контрагентам. На первом листе книги ведётся динамика изменений.
контрагенты прибавляются и отваливаются, соответственно
при копировании нового листа в итоговый файл они добавляются, но в динамике не участвуют.
в копируемом листе ячейка с ИНН контрагента выделена цветом.
Попытался с помощью присвоения переменной номера цвета, которым выделена ячейка с ИНН выделить и скопировать на страницу динамики в столбец ИНН, ничего не получилось.
Можете подсказать, как скопировать из второго листа все ИНН выделенные цветом на первый лист с добавлением отсутствующих.
и дублированием в новых строчках с новыми ИНН всех формул как у остальных.
А у отсутствующих контрагентов в результатах должен быть "ноль" а не "Н/Д".
образец примерный прилагаю.
Подскажите как можно проще?

[PetyaVova]

Кто ни будь, откликнитесь..

[PetyaVova]

Спасибо, с Н/Д перевести в ноль помогли, этот вопрос снимаю.
как всегда оказалось просто.

=ЕСЛИОШИБКА(...)

с остальным не понятно.

[Aleksandr H.]

Чем AddNewINN не устраивает? Нормально ведь работает! Кто-то не поленился даже откомментить каждую строку.

[PetyaVova]

Сообщение от Aleksandr H.

Чем AddNewINN не устраивает? Нормально ведь работает! Кто-то не поленился даже откомментить каждую строку.

копируется непонятно куда, а мне надо в предпоследнюю строчку со смещением последней и копированием формул.

[PetyaVova]

Сообщение от PetyaVova

Спасибо, с Н/Д перевести в ноль помогли, этот вопрос снимаю.

оказалось не всё, в одной ячейке вместо Н/Д надо оставить предыдущее значение(название фирмы).

[PetyaVova]

Сообщение от Aleksandr H.

Чем AddNewINN не устраивает? Нормально ведь работает! Кто-то не поленился даже откомментить каждую строку.

Сообщение от Aleksandr H.

Чем AddNewINN не устраивает? Нормально ведь работает! Кто-то не поленился даже откомментить каждую строку.

Получилось.

Option Explicit
Sub AddNewINN()
    Dim sh As Worksheet
    Dim sh1 As Worksheet
    Dim rCOunt As Long
    Dim i
    Dim myColor
    Dim myCell
    Dim newCell
    Dim lastrow As Long
    
 Set sh = Sheets(2)
 Set sh1 = Sheets(1)
' lastrow = Sheets("Динамика").Range("A65536").End(xlUp).Row
 With sh
 rCOunt = .Cells(.Rows.Count, 1).End(xlUp).Row
 myColor = sh.Range("D9").Interior.Color
 For i = 9 To rCOunt
 If .Cells(i, "D").Interior.Color = myColor Then
 Set myCell = sh1.Range("B:B").Find(.Cells(i, "D"))
 If myCell Is Nothing Then Set newCell = (.Cells(i, "D"))
      
    If newCell <> 0 Then
         Sheets("Динамика").Select
          lastrow = Sheets("Динамика").Range("A65536").End(xlUp).Row
     Range("A" & lastrow).Select
     ActiveCell.EntireRow.Select
     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    MsgBox (newCell & " копировать в Лист1")
    Range("B" & lastrow).Select
      newCell.Copy 'Destination:=Sheets("Динамика").Range("B" & lastrow)
          Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      End If
    End If
    Next i
    End With
    Set sh = Nothing
    Set sh1 = Nothing
      End Sub

осталось подставить формулы

[PetyaVova]

Сообщение от PetyaVova

Получилось.

Option Explicit
Sub AddNewINN()
    Dim sh As Worksheet
    Dim sh1 As Worksheet
    Dim rCOunt As Long
    Dim i
    Dim myColor
    Dim myCell
    Dim newCell
    Dim lastrow As Long
    
 Set sh = Sheets(2)
 Set sh1 = Sheets(1)
' lastrow = Sheets("Динамика").Range("A65536").End(xlUp).Row
 With sh
 rCOunt = .Cells(.Rows.Count, 1).End(xlUp).Row
 myColor = sh.Range("D9").Interior.Color
 For i = 9 To rCOunt
 If .Cells(i, "D").Interior.Color = myColor Then
 Set myCell = sh1.Range("B:B").Find(.Cells(i, "D"))
 If myCell Is Nothing Then Set newCell = (.Cells(i, "D"))
      
    If newCell <> 0 Then
         Sheets("Динамика").Select
          lastrow = Sheets("Динамика").Range("A65536").End(xlUp).Row
     Range("A" & lastrow).Select
     ActiveCell.EntireRow.Select
     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    MsgBox (newCell & " копировать в Лист1")
    Range("B" & lastrow).Select
      newCell.Copy 'Destination:=Sheets("Динамика").Range("B" & lastrow)
          Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      End If
    End If
    Next i
    End With
    Set sh = Nothing
    Set sh1 = Nothing
      End Sub

осталось подставить формулы

подсказали и всё получилось.

Option Explicit
Sub AddNewINN()
    Dim sh As Worksheet
    Dim sh1 As Worksheet
    Dim rCOunt As Long
    Dim i
    Dim myColor
    Dim myCell
    Dim newCell
    Dim lastrow As Long

    Set sh = Sheets(2)
    Set sh1 = Sheets(1)
    ' lastrow = Sheets("Динамика").Range("A65536").End(xlUp).Row
    With sh
        rCOunt = .Cells(.Rows.Count, 1).End(xlUp).Row
        myColor = sh.Range("D9").Interior.Color
        For i = 26 To rCOunt
            If .Cells(i, "D").Interior.Color = myColor Then
                Set myCell = sh1.Range("B:B").Find(.Cells(i, "D"))
                If myCell Is Nothing Then Set newCell = (.Cells(i, "D"))

                If newCell = (.Cells(i, "D")) Then
                    lastrow = sh1.Range("A65536").End(xlUp).Row - 1
                    sh1.Rows(lastrow - 1).Copy
                    sh1.Rows(lastrow).Insert xlDown, xlFormatFromLeftOrAbove
                    sh1.Range("B" & lastrow).Value = newCell.Value
                    Application.CutCopyMode = 0
                End If
            End If
        Next i
    End With
    Set sh = Nothing
    Set sh1 = Nothing

End Sub

но остался вопрос по отсутствующим контрагентам, как оставить информацию в ячейке если с обновлением информация отсутствует.?