Sub SavePDFnoIMG()
    Dim s As Worksheet
    For Each s In ActiveWorkbook.Worksheets
        s.ExportAsFixedFormat Filename:=ThisWorkbook.Path & "\" & s.Name & ".pdf", Type:=xlTypePDF
    Next
End Sub

=СЧЁТЕСЛИМН($A$7:$A$100;P1;$D$7:$D$100;$D$1;$G$7:$G$100;$G$1;$J$7:$J$100;">0")

Sub Макрос21()
Application.ScreenUpdating = False
Dim Wb1 As Workbook
Dim Wb2 As Workbook
 
Dim Cl As Range
Set Wb1 = Workbooks("Сводный реестр обработанных закупок.xlsm")
Set Wb2 = ActiveWorkbook
On Error Resume Next
With Wb1.Worksheets("Лист1")
    lRow = .Cells.SpecialCells(xlLastCell).Row
     
   Dim rngX As Range
   Dim i As Integer
   Set rngX = .Range("A1:A" & lRow)
    For i = 6 To 52 Step 3
        Set rngX = Union(rngX, .Range("A1:A" & lRow).Offset(, i))
    Next i
    Dim tmp
    For Each Cl In rngX.Cells
        tmp = Cl.Offset(, 2).Value
        Wb2.Worksheets("Лист1").Cells.Find(Cl.Value, LookAt:=xlWhole).Offset(2, 1) = tmp
    Next
    Application.ScreenUpdating = True
End With
End Sub