Sub test()
    Dim Adr$
    Adr = [d2]
    Range(Adr).Value = Range("E2").Value
End Sub

        If LastCol < .Columns.Count Then
          With .Range(.Columns(LastCol + 1), .Columns(.Columns.Count))
            .EntireColumn.Delete ' rev4.
            If LastCol >= ShpLastCol Then
              ' Set StandardWidth to columns which are beyond the last col
              .EntireColumn.ColumnWidth = IIf(Ws.StandardWidth, Ws.StandardWidth, 8.43)  'Ws.StandardWidth
            End If
          End With
          If ShpLastCol < .Columns.Count Then
            ' Set StandardWidth to columns which are beyond the Shapes
            With .Range(.Columns(ShpLastCol + 1), .Columns(.Columns.Count))
              .EntireColumn.ColumnWidth = IIf(.StandardWidth, .StandardWidth, 8.43)  'Ws.StandardWidth
            End With
          End If
        End If
        ' Clear cells beyond the last row
        If LastRow < .Rows.Count Then
          With .Range(.Rows(LastRow + 1), .Rows(.Rows.Count))
            .EntireRow.Delete ' rev.4
            If LastRow >= ShpLastRow Then
              ' Set StandardWidth to rows which are beyond the last row
              .EntireRow.RowHeight = IIf(Ws.StandardHeight, Ws.StandardHeight, 12.75)
            End If
          End With
          If ShpLastRow < .Rows.Count Then
            ' Set StandardHeight to rows which are beyond the Shapes
            With .Range(.Rows(ShpLastRow + 1), .Rows(.Rows.Count))
              .EntireRow.RowHeight = IIf(.StandardHeight, .StandardHeight, 12.75)
            End With
          End If
       End If

        If ShpLastCol < .Columns.Count Then
          With .Range(.Columns(ShpLastCol + 1), .Columns(.Columns.Count))
            .EntireColumn.Delete ' rev4.
            If LastCol >= ShpLastCol Then
              ' Set StandardWidth to columns which are beyond the last col
              .EntireColumn.ColumnWidth = IIf(Ws.StandardWidth, Ws.StandardWidth, 8.43)  'Ws.StandardWidth
            End If
          End With
          If ShpLastCol < .Columns.Count Then
            ' Set StandardWidth to columns which are beyond the Shapes
            With .Range(.Columns(ShpLastCol + 1), .Columns(.Columns.Count))
              .EntireColumn.ColumnWidth = IIf(.StandardWidth, .StandardWidth, 8.43)  'Ws.StandardWidth
            End With
          End If
        End If
        ' Clear cells beyond the last row
        If ShpLastRow < .Rows.Count Then
          With .Range(.Rows(ShpLastRow + 1), .Rows(.Rows.Count))
            .EntireRow.Delete ' rev.4
            If LastRow >= ShpLastRow Then
              ' Set StandardWidth to rows which are beyond the last row
              .EntireRow.RowHeight = IIf(Ws.StandardHeight, Ws.StandardHeight, 12.75)
            End If
          End With
          If ShpLastRow < .Rows.Count Then
            ' Set StandardHeight to rows which are beyond the Shapes
            With .Range(.Rows(ShpLastRow + 1), .Rows(.Rows.Count))
              .EntireRow.RowHeight = IIf(.StandardHeight, .StandardHeight, 12.75)
            End With
          End If
        End If

Sub Grafik_excel()
    Dim ws          As Worksheet
    Dim xRg         As Range
    Dim xChart      As ChartObject
    ListIkl = Array("Лист3", "Лист4")    'листы, которые нужно исключить
    For Each ws In Worksheets    'для каждого листа
        If Not IsNumeric(Application.Match(ws.Name, ListIkl, 0)) Then
            ws.Shapes.AddChart2(240, xlXYScatterSmoothNoMarkers).Select
            Set xRg = Range("B5:M20")
            Set xChart = ws.ChartObjects(1)
            With xChart
                .Top = xRg(1).Top
                .Left = xRg(1).Left
                .Width = xRg.Width
                .Height = xRg.Height
            End With
            With xChart.Chart
                'данные для построения графиков
                .SeriesCollection.NewSeries
                .FullSeriesCollection(1).XValues = "='" & ws.Name & "'!$N$2:$X$2"
                .FullSeriesCollection(1).Values = "='" & ws.Name & "'!$N$3:$X$3"
                .SeriesCollection.NewSeries
                .FullSeriesCollection(2).XValues = "='" & ws.Name & "'!$N$4:$X$4"
                .FullSeriesCollection(2).Values = "='" & ws.Name & "'!$N$5:$X$5"
                .SeriesCollection.NewSeries
                .FullSeriesCollection(3).XValues = "='" & ws.Name & "'!$N$6:$X$6"
                .FullSeriesCollection(3).Values = "='" & ws.Name & "'!$N$7:$X$7"
            End With
        End If
    Next
End Sub

Sub Grafik_excel()
    Dim ws          As Worksheet
    Dim xRg         As Range
    Dim xChart      As ChartObject
    For Each ws In Worksheets    'для каждого листа
        ws.Shapes.AddChart2(240, xlXYScatterSmoothNoMarkers).Select
        Set xRg = Range("B5:M20")
        Set xChart = ws.ChartObjects(1)
        With xChart
            .Top = xRg(1).Top
            .Left = xRg(1).Left
            .Width = xRg.Width
            .Height = xRg.Height
        End With
        With xChart.Chart
            'данные для построения графиков
            .SeriesCollection.NewSeries
            .FullSeriesCollection(1).XValues = "='" & ws.Name & "'!$N$2:$X$2"
            .FullSeriesCollection(1).Values = "='" & ws.Name & "'!$N$3:$X$3"
            .SeriesCollection.NewSeries
            .FullSeriesCollection(2).XValues = "='" & ws.Name & "'!$N$4:$X$4"
            .FullSeriesCollection(2).Values = "='" & ws.Name & "'!$N$5:$X$5"
            .SeriesCollection.NewSeries
            .FullSeriesCollection(3).XValues = "='" & ws.Name & "'!$N$6:$X$6"
            .FullSeriesCollection(3).Values = "='" & ws.Name & "'!$N$7:$X$7"
        End With
    Next
End Sub

ActiveChart.FullSeriesCollection(1).XValues= "='" & ActiveSheet.Name & "'!A1:A10"
ActiveChart.FullSeriesCollection(1).Values= "='" & ActiveSheet.Name & "'!B1:B10"

wb.Sheets("Калькуляция").Name = ThisWorkbook.Sheets("Калькуляция").Range("A1").Value

Sub Sel_UserAutoFit()
    UserAutoFit Selection
End Sub

Public Function UserAutoFit(ByRef objRange As Object) As Boolean
    Dim j&, q&, f&, l&, p&(3), cWh!, rHh!, I() As Box, cl() As Single, X As Object
    On Error GoTo L2
    With Application
        .ScreenUpdating = False
        'v = .ActiveWindow.View: .ActiveWindow.View = xlNormalView
        If TypeName(objRange) = "Range" Then
            With .Sheets(objRange.Parent.Name)    '.ActiveSheet
                ' .DisplayPageBreaks = False
                For Each X In objRange.Areas
                    Set X = IIf(X.Address = .Rows.Address Or X.Address = .Columns(X.Column).Address, .UsedRange, X): p(0) = X.Column
                    p(1) = p(0) + X.Columns.count - 1: p(2) = X.Row: p(3) = p(2) + X.Rows.count - 1: ReDim cl(p(0) To p(1)): ReDim I(p(2) To p(3))
                    For j = p(0) To p(1): cl(j) = .Columns(j).ColumnWidth: Next
                    For j = p(3) To p(2) Step -1
                        Set X = .Rows(j): I(j).Hdn = X.Hidden: X.AutoFit: I(j).Hght = X.RowHeight
                        For l = p(0) To p(1)
                            If .Cells(j, l).MergeCells Then
                                With .Cells(j, l).MergeArea
                                    If .Parent.Cells(j, l).Address = .item(1).Address Then
                                        For q = l To l + .Columns.count - 1: cWh = cWh + cl(q) + 0.647: Next
                                        If cWh > 255 Then cWh = 0: GoTo L1
                                        For q = j To j + .Rows.count - 1
                                            If Not I(q).Hdn Then rHh = rHh + I(q).Hght: If f = 0 Then f = q
                                        Next
                                        .UnMerge: .item(1).ColumnWidth = cWh: X.AutoFit: rHh = X.RowHeight - (rHh - I(f).Hght)
                                        If f <> j Then If I(f).Hght < rHh Then .Rows(f - j + 1).RowHeight = rHh
                                        .Merge: .item(1).ColumnWidth = cl(l): l = l + .Columns.count - 1
                                        If I(f).Hght < rHh Then I(f).Hght = rHh
                                        cWh = 0: rHh = 0: f = 0
                                    End If
                                End With
                            End If
L1:                             Next
                        If I(j).Hght > 0 Then X.RowHeight = I(j).Hght
                        If I(j).Hdn Then X.Hidden = True
                    Next
                Next
            End With
        End If
        ' .ActiveWindow.View = v
    End With
L2:     End Function

Sub tt()
    Dim PDFrng As Range, PDF As Range
    Dim AdobeReader As String, pdfLINK As String
    Set PDFrng = ActiveSheet.Range("A100:A109")
    Dim objShell
    Set objShell = CreateObject("Shell.Application")
    For Each PDF In PDFrng
        If PDF.Hyperlinks.Count > 0 Then pdfLINK = PDF.Hyperlinks(1).Address
        objShell.ShellExecute pdfLINK, "", "", "print", 0
        Application.Wait Now + TimeValue("00:00:01")
    Next PDF
End Sub

Dim filterArray(), FiltrRange

Sub SaveFl()
' сохранение значений автофильтра
    Set wsh = ActiveSheet
    With wsh.AutoFilter
        FiltrRange = .Range.Address
        With .Filters
            ReDim filterArray(1 To .Count, 1 To 3)
            For f = 1 To .Count
                With .Item(f)
                    If .On Then
                        filterArray(f, 1) = .Criteria1
                        If .Operator Then
                            filterArray(f, 2) = .Operator
                            filterArray(f, 3) = .Criteria2
                        End If
                    End If
                End With
            Next f
        End With
    End With
End Sub


Public Sub LoadFL() ' загрузка значений автофильтра
    Set wsh = ActiveSheet
    For col = 1 To UBound(filterArray(), 1)
        If Not IsEmpty(filterArray(col, 1)) Then
            If filterArray(col, 2) Then
                wsh.Range(FiltrRange).AutoFilter field:=col, _
                        Criteria1:=filterArray(col, 1), _
                        Operator:=filterArray(col, 2), _
                        Criteria2:=filterArray(col, 3)
            Else
                wsh.Range(FiltrRange).AutoFilter field:=col, _
                        Criteria1:=filterArray(col, 1)
            End If
        End If
    Next col
End Sub

<customUI xmlns = "http://schemas.microsoft.com/office/2009/07/customui" onLoad = "RibbonOnLoad">
   <ribbon startFromScratch = "false">
      <tabs>
         <tab id = "Вкладка1" label = "Моя вкладка">
            <group id = "Группа1" label = "Моя группа">
               <labelControl id = "Lbl1" getLabel = "GetText"/>
            </group>
         </tab>
      </tabs>
   </ribbon>
</customUI>

Option Explicit

Public ribbon As IRibbonUI
Public sText As String
Public ev As New Class1
Sub Auto_open()
    Set ev.ap = Excel.Application
End Sub

Sub RibbonOnLoad(IRibbon As IRibbonUI)
    Set ribbon = IRibbon
End Sub

Public Sub GetText(control As IRibbonControl, ByRef label)
    label = sText
End Sub

Option Explicit

Public WithEvents ap As Excel.Application
Private Sub ap_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    sText = "кол-во: " & WorksheetFunction.CountA(ActiveSheet.Columns(1))
    ribbon.InvalidateControl "Lbl1"
End Sub

Private Sub ap_SheetActivate(ByVal Sh As Object)
    sText = "кол-во: " & WorksheetFunction.CountA(ActiveSheet.Columns(1))
    ribbon.InvalidateControl "Lbl1"
End Sub

<customUI xmlns = "http://schemas.microsoft.com/office/2009/07/customui" onLoad = "RibbonOnLoad">
   <ribbon startFromScratch = "false">
      <tabs>
         <tab id = "Вкладка1" label = "Моя вкладка">
            <group id = "Группа1" label = "Моя группа">
               <button id = "Кнопка1" imageMso = "AppointmentColor0" onAction = "SetText" getLabel = "GetText"/>
            </group>
         </tab>
      </tabs>
   </ribbon>
</customUI>

Option Explicit

Public ribbon As IRibbonUI
Public sText As String

Sub RibbonOnLoad(IRibbon As IRibbonUI)
    Set ribbon = IRibbon
End Sub

Public Sub GetText(control As IRibbonControl, ByRef label)
    label = sText
End Sub

Public Sub SetText(ctrl As IRibbonControl)
    sText = WorksheetFunction.CountA(Columns(1))
    ribbon.InvalidateControl "Кнопка1"
End Sub