Private Sub CommandButton1_Click()
 Dim a As Variant
 Dim b As Variant
 Dim c As Variant
Dim sheet As Worksheet, LO As ListObject
For Each sheet In Sheets
For Each LO In sheet.ListObjects
With LO
  a = .Name
  'MsgBox a
  b = .Parent.Name
  'MsgBox b
  c = .Range.Address
  'MsgBox c
End With
Next
Next
End Sub

Private Sub СохранитьРасчёт()
 Sheets("Калькуляция").Select
Application.ScreenUpdating = False:
    Dim b
        b = "Калькуляция" 'задаем переменную
CreateObject("Shell.Application").Namespace(ThisWorkbook.Path).NewFolder (b) 'создаем папку
Dim wb1 As Workbook
    Set wb1 = Workbooks.Add 'создаем новую книгу
           With ThisWorkbook.Sheets("Калькуляция") 'выбираем лист для копирования
            .Copy wb1.Sheets(1) 'копируем лист
                Sheets("Калькуляция").Name = Range("A1").Value 'присваиваем листу имя
            wb1.SaveAs Filename:=ThisWorkbook.Path & "\" & b & "\" & "Калькуляция, " & Range("A1").Value & ".xlsx"  'сохраняем нашу книгу со всеми изменениями
         End With
 'удаляем все пустые листы
    Application.DisplayAlerts = False
    Dim sh2 As Worksheet
    For Each sh2 In Sheets
        If IsEmpty(sh2.UsedRange) Then sh2.Delete
    Next
    Application.DisplayAlerts = True
ActiveWorkbook.Save
    wb1.Close 'закрываем новую книгу
    
End Sub

Private Sub ДобавитьСтроки_Click()
  Dim myTable As ListObject
 Dim vRetVal
 Dim fcell3 As Variant
 Dim b3 As Variant
 Dim a3 As Variant
Dim c3 As Variant

'Вписываем количество строк, на которые увеличиваем таблицу
vRetVal = InputBox("Укажите количество строк, которые нужно добавить(целое число):", "Вставка новых строк", "")
 c3 = Val(vRetVal)
 
'Поиск заголовка над таблицей
Set fcell3 = Columns("A:A").Find(ИмяПодраздела.Text)
If Not fcell3 Is Nothing Then
Range("A" & fcell3.Row + 2).Select 'активная ячейка для определения по ней имени таблицы
b3 = ActiveCell.ListObject.Name 'ИМЯ ТАБЛИЦЫ

'Определение количества строк в таблице
Set myTable = Worksheets(ИмяРаздела.Text).ListObjects(b3)
'MsgBox myTable.DataBodyRange.Rows.Count
a3 = myTable.DataBodyRange.Rows.Count

ActiveSheet.ListObjects(b3).Range.Resize (a3 + c3)

If StrPtr(vRetVal) = 0 Then
    'MsgBox "Нажата кнопка Отмена. Процедура прервана", vbCritical, "DelCols"
    Exit Sub
End If
End If
End Sub

    Dim xTable As ListObject
    Dim xSheet As Worksheet
    Dim I As Long
    I = -1
    Sheets("Настройки").Select
    For Each xSheet In Worksheets
        For Each xTable In xSheet.ListObjects
            I = I + 1
            Sheets("Настройки").Range("C1").Offset(I).Value = xTable.Name
        Next xTable
    Next

Private Sub ПоискВТаблице_Click()
Sheets(ИмяРаздела.Text).Select
Dim tbl As ListObject
Dim FoundCell As Range
Dim LookupValue As String
Dim a As Variant

  LookupValue = ИмяФурнитуры.Text
  Set tbl = ActiveSheet.ListObjects(ИмяПодраздела.Text)
  On Error Resume Next
  Set FoundCell = tbl.DataBodyRange.Columns(1).Find(LookupValue, LookAt:=xlWhole)
  On Error GoTo 0
  If Not FoundCell Is Nothing Then
  'если найдено
    MsgBox "Found in table row: " & _
      tbl.ListRows(FoundCell.Row - tbl.HeaderRowRange.Row).Index
      a = tbl.ListRows(FoundCell.Row - tbl.HeaderRowRange.Row).Index
    MsgBox a
    
 'НАЙТИ КОД ОБРАЩЕНИЯ К ЯЧЕЙКЕ ТАБЛИЦЫ ДЛЯ ВВОДА ДАННЫХ
'With ActiveSheet.ListObjects(ИмяФурнитуры.Text)
    'Debug.Print .Range.Cells(3, a).Value = ЦенаЗаЕд.Text
'End With
   
  Else
 'если не найдено
 Call НоваяФурнитура
  End If
End Sub

Private Sub ИмяПодраздела_Change()

'MsgBox Not IsError(Application.Match(ИмяПодраздела.Text, Columns(1), 0))
If IsError(Application.Match(ИмяПодраздела.Text, Columns(1), 0)) = False Then
Exit Sub
Else

'If Columns(1).Find(ИмяПодраздела.Text) Is Nothing Then MsgBox "Нет" Else MsgBox "Да"

'If ИмяПодраздела.Text = "" Then
        'Exit Sub
        'Else
 Dim fcell As Variant
 'Dim a As Variant
Set fcell = Columns("A:A").Find(ИмяПодраздела.Text) 'Поиск имени подраздела в столбце А, находит номер строки
If Not fcell Is Nothing Then
If fcell = "" Then
Exit Sub
Else
'a = Range("A" & fcell.Row).Value 'Наименование таблицы (имя подраздела)
'If a = ИмяРаздела.Text Then
'Exit Sub
'Else



With ActiveSheet.ListObjects(Range("A" & fcell.Row).Value)
    'Обращение через диапазон умной таблицы
Debug.Print .DataBodyRange.Columns(1).Address
ИмяФурнитуры.RowSource = .DataBodyRange.Columns(1).Address 'Заполнение combobox (имя фурнитуры)диапазоном из таблицы
End With
'End If
End If
End If
End If

End Sub

Private Sub ИмяПодраздела_Change()
If ИмяПодраздела.Text = "" Then
        Exit Sub
        Else
 Dim fcell As Variant
 Dim a As Variant
Set fcell = Columns("A:A").Find(ИмяПодраздела.Text) 'Поиск имени подраздела в столбце А, находит номер строки
If Not fcell Is Nothing Then
a = Range("A" & fcell.Row).Value 'Наименование таблицы (имя подраздела)
With ActiveSheet.ListObjects(a)
    'Обращение через диапазон умной таблицы
Debug.Print .Range.Columns(1).Address
Debug.Print .Range.Columns.Count
ИмяФурнитуры.RowSource = .Range.Columns(1).Address 'Заполнение combobox (имя фурнитуры)диапазоном из таблицы
End With
End If
End If

End Sub

Dim a()
a = Range("ИмяПодраздела.Text[Наименование]").Value
ИмяФурнитуры.List = a

Dim a()
a = Range("Кухонные[Наименование]").Value
ИмяФурнитуры.List = a

If Target.Cells.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("I:I")) Is Nothing Then
    If Cells(Target.Row, Target.Column) = "Нет цены в прайсе" Then 'Проверка есть ли в столбце I:I текст *Нет цены в прайсе*
        MsgBox "Внесите данные в прайс или впишите стоимость в ячейку " & "G" & Target.Row
     Worksheets("Калькуляция").Range("G" & Target.Row).Locked = False
Worksheets("Калькуляция").Protect
    End If
End If

Private Sub Worksheet_Calculate()
Call НеВыпускают
End Sub

 Private Sub НеВыпускают()
 Dim a75 As Variant, a76 As Variant, a77 As Variant, a78 As Variant, a79 As Variant, a80 As Variant, a81 As Variant, a82 As Variant, a83 As Variant, a84 As Variant
 Dim b1 As Variant
 a75 = Range("I75").Value
 a76 = Range("I76").Value
 a77 = Range("I77").Value
 a78 = Range("I78").Value
 a79 = Range("I79").Value
 a80 = Range("I80").Value
 a81 = Range("I81").Value
 a82 = Range("I82").Value
 a83 = Range("I83").Value
 a84 = Range("I84").Value
 b1 = "не бывает"
 'Application.EnableEvents = False
    If a75 = b1 Or a76 = b1 Or a77 = b1 Or a78 = b1 Or a79 = b1 Or a80 = b1 Or a81 = b1 Or a82 = b1 Or a83 = b1 Or a84 = b1 Then
    MsgBox "Столешницы в выбранном сочетании не выпускают", vbExclamation, "Категория"
    'Application.EnableEvents = True
    End If
End Sub

Private Sub ОбщийВид_Click() 'Картинка в ячейку A2
  Application.ScreenUpdating = False
     Dim profile As String
    On Error Resume Next
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "Picture Files", "*.bmp;*.jpg;*.gif;*.png"
        .ButtonName = "Select"
        .AllowMultiSelect = False
        .Title = "Choose Photo"
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
    With ActiveSheet.Range("A2")
        ActiveSheet.Shapes.AddPicture FileName:=fd.SelectedItems(1), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoCTrue, _
            Left:=.Left - 1, _
            Top:=.Top - 1, _
            Width:=-1, _
            Height:=-1
   Навигация.Изображение.BackColor = vbGreen
    End With
    Application.ScreenUpdating = True
End Sub

Private Sub ДопИзо_Click()  'Картинка по высоте объединённых ячеек H36:M65
  Application.ScreenUpdating = False
    Dim strFullName As String, objShape As Shape
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Рисунки", "*.jpg"
        If .Show = 0 Then
            Exit Sub
        End If
        strFullName = .SelectedItems(1)
    End With
    Set objShape = ActiveSheet.Shapes.AddPicture(strFullName, False, True, Range("H36").Left, Range("H36").Top, -1, -1)
    objShape.LockAspectRatio = True
    objShape.Height = Range("H36:M65").Height
    Application.ScreenUpdating = True
End Sub

Private Sub ЛДСП1_Проект()

Dim lLastRow As Long
    With Sheets("Проект") 'Работаем на листе Проект
        lLastRow = .Cells(.Rows.count, 15).End(xlUp).Row + 1 'Определение первой свободной ячейки в столбце О
   If Len(Trim(ЛДСП.Выбор1ЛДСПИтог.Caption)) > 0 Then
       .Range("O" & lLastRow) = ЛДСП.Выбор1ЛДСПИтог.Caption 'Наим ЛДСП 1
       .Range("P" & lLastRow) = ЛДСП.Поле1_5.Text  'Приобретение ЛДСП 1
       .Range("Q" & lLastRow) = ЛДСП.Поле1_6.Text  'Обработка ЛДСП 1
       End If
   If Len(Trim(ЛДСП.Выбор1КромкаИтог.Caption)) > 0 Then
       .Range("O" & lLastRow + 1) = ЛДСП.Выбор1КромкаИтог.Caption 'Наим ЛДСП 1 кромка 1
       .Range("P" & lLastRow + 1) = ЛДСП.Поле1_8.Text 'Приобретение ЛДСП 1 кромка 1
       End If
   If Len(Trim(ЛДСП.Выбор1Кромка2Итог.Caption)) > 0 Then
       .Range("O" & lLastRow + 2) = ЛДСП.Выбор1Кромка2Итог.Caption 'Наим ЛДСП 1 кромка 2
       .Range("P" & lLastRow + 2) = ЛДСП.Поле1_10.Text 'Приобретение ЛДСП 1 кромка 2
       End If
   If Len(Trim(ЛДСП.Выбор1Кромка3Итог.Caption)) > 0 Then
       .Range("O" & lLastRow + 3) = ЛДСП.Выбор1Кромка3Итог.Caption 'Наим ЛДСП 1 кромка 3
       .Range("P" & lLastRow + 3) = ЛДСП.Поле1_12.Text 'Приобретение ЛДСП 1 кромка 3
       End If
    .Range("O" & lLastRow).WrapText = True 'включение автопереноса слов
    .Rows(lLastRow).EntireRow.AutoFit 'включение автоподбора высоты строки
    
'Подсчёт заполненных ячеек в массиве
  'Dim x&
'x = WorksheetFunction.CountA(["O" & lLastRow:"O" & lLastRow + 3])
'MsgBox "Заполненных ячеек " & WorksheetFunction.CountA(["O" & lLastRow:"O" & lLastRow + 3]), vbExclamation

       End With
       
 'Объёдинение ячеек
     'Range("N3:N5").Select
    'With Selection
        '.HorizontalAlignment = xlCenter
        '.VerticalAlignment = xlCenter
        '.WrapText = False
        '.Orientation = 0
        '.AddIndent = False
        '.IndentLevel = 0
        '.ShrinkToFit = False
        '.ReadingOrder = xlContext
        '.MergeCells = False
   ' End With
   ' Selection.Merge
       

End Sub