Sub Очистить_журнал()

    If MsgBox("Очистить журнал?", vbYesNo + vbQuestion, "Вопрос") = vbNo Then Exit Sub
    
    With Sheets("Журнал 1")
        .Activate
        .Range("A2:H101").ClearContents
        .Range("I1").Select
    End With
    
    With Sheets("ОТК")
        .Range("B8:C52").ClearContents
        .Range("E8:F52").ClearContents
        .Range("H8:I17").ClearContents
    End With
End Sub

Sub Test()
    Dim sFolder As String, PDF_filename As String, sSheetName As String
    
    'папка, куда будем сохранять файлы PDF
    sFolder = "C:\Temp\" 'поставьте \ в конце имени папки
    
    'сохраняем 1-й лист
    sSheetName = "Лист1"  '<-- укажите имя листа для сохранения в PDF
    PDF_filename = "яблоки " & Format$(Date, "DD/MM/YYYY") '<-- имя файла PDF. После имени файла стоит пробел
    Worksheets(sSheetName).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolder & PDF_filename & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
    
    'сохраняем 2-й лист
    sSheetName = "Лист2"  '<-- укажите имя листа для сохранения в PDF
    PDF_filename = "груши " & Format$(Date, "DD/MM/YYYY") '<-- имя файла PDF. После имени файла стоит пробел
    Worksheets(sSheetName).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolder & PDF_filename & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
    
    'сохраняем 3-й лист
    sSheetName = "Лист3"  '<-- укажите имя листа для сохранения в PDF
    PDF_filename = "мандарины  " & Format$(Date, "DD/MM/YYYY") '<-- имя файла PDF. После имени файла стоит пробел
    Worksheets(sSheetName).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolder & PDF_filename & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
    MsgBox "Листы сохранены в PDF!", vbInformation, "Информация"
End Sub

Sub Test()
    Dim CountNonEmpty As Long
    CountNonEmpty = WorksheetFunction.CountA(Range("H6:XFD6"))
    MsgBox CountNonEmpty
End Sub

Public Function DeleteTableRows(table As ListObject, Optional isEntireRowDeletion = True)
    With table
        If Not .DataBodyRange Is Nothing Then
            If isEntireRowDeletion Then
                .DataBodyRange.EntireRow.Delete
            Else
                .DataBodyRange.Delete
            End If
        End If

        table.ShowTotals = False
        ' создать строку в DataBodyRange
        table.ListRows.Add (1)
        table.ShowTotals = True
    End With
End Function

.UsedRange.Value = .UsedRange.Value

.UsedRange.NumberFormat = "@"

.UsedRange.NumberFormat = "@"
.UsedRange.Value = .UsedRange.Value

If ThisWorkbook.ReadOnly = True Then ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite

Sub Clean1CReport()
    Dim wsReport As Worksheet, wsResult As Worksheet
    Dim rCell As Range, rDest As Range
    Dim sManager As String, sBuyer As String
    
    Set wsResult = ThisWorkbook.Worksheets("Result")
    With wsResult
        .UsedRange.Rows.Delete
        .Range("A1").Resize(1, 10) = Array("Менеджер", "Покупатель", "Номенклатура", "Закупка", "Отгрузка", "Оплата", "% отг", "% опл", "Наценка", "ВП")
        Set rDest = .Range("A2")
    End With
    
    Set wsReport = ThisWorkbook.Worksheets("TDSheet")
    
    For Each rCell In wsReport.UsedRange.Columns(1).Cells
        If rCell.EntireRow.OutlineLevel = 2 Then sManager = rCell.Value
        If rCell.EntireRow.OutlineLevel = 3 Then sBuyer = rCell.Value
        If rCell.EntireRow.OutlineLevel = 4 Then
            rDest.Resize(1, 10).Value = Array(sManager, sBuyer, rCell.Value, rCell.Offset(, 1).Value, rCell.Offset(, 2).Value, rCell.Offset(, 3).Value, _
                rCell.Offset(, 5).Value, rCell.Offset(, 7).Value, rCell.Offset(, 9).Value, rCell.Offset(, 11).Value)
            Set rDest = rDest.Offset(1)
        End If
    Next rCell
    
    wsResult.Activate
End Sub

Sub Test()
    Dim Rng As Range
    
    Set Rng = Range("A1:Z100").Find("мама", , xlFormulas, xlWhole)
    If Rng Is Nothing Then
        MsgBox "Не найдено!", vbExclamation, "Внимание"
        Exit Sub
    End If
    
    MsgBox "Адрес найденной ячейки: " & Rng.Address(0, 0)    
    MsgBox "Значение соседней справа ячейки: " & Rng.Offset(, 1).Value
End Sub

Sub Test()
    Dim iRow As Long
    For iRow = 3 To 30
        Range("J" & iRow).FormulaLocal = "=ЕСЛИОШИБКА(ВПР(C" & iRow & ";'БАЗА ДАННЫХ'!B:G;2;0);"""")"
    Next iRow
End Sub