Sub Protection()
    Dim ws As Worksheet
    ActiveWorkbook.Protect Password:=123, Structure:=True
    For Each ws In Worksheets
        ws.Protect Password:=123, UserInterfaceOnly:=True: ws.EnableSelection = xlNoRestrictions
    Next
End Sub

Sub replace()
    fname = ThisWorkbook.Path + "\" + ThisWorkbook.Name
   
        ' как-то разорвать связь исходника с диском, чтоб иметь возможность записать поверх.
     
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=fname, FileFormat _
        :=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWindow.Close
End Sub

Sub sendMail()
    Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/"
    Dim oCDOCnf As Object, oCDOMsg As Object
    Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String
    Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String
    On Error Resume Next
    'sFrom – как правило совпадает с sUsername
    SMTPserver = "smtp-relay.gmail.com"    ' SMTPServer
    sUsername = "email_01@gmail.com"    ' Учетная запись на сервере
    sPass = "*****"    ' Пароль к почтовому аккаунту
 
    If Len(SMTPserver) = 0 Then MsgBox "Не указан SMTP сервер", vbInformation, "www.Excel-VBA.ru": Exit Sub
    If Len(sUsername) = 0 Then MsgBox "Не указана учетная запись", vbInformation, "www.Excel-VBA.ru": Exit Sub
    If Len(sPass) = 0 Then MsgBox "Не указан пароль", vbInformation, "www.Excel-VBA.ru": Exit Sub
 
    sTo = "email_02@gmail.com"    'Кому
    sFrom = "email_01@gmail.com"    'От кого
    sSubject = "Автоотправка"    'Тема письма
    sBody = "Проверка отправки"    'Текст письма
    sAttachment = "C:/Temp/Книга1.xls"    'Вложение(полный путь к файлу)
 
    'Назначаем конфигурацию CDO
    Set oCDOCnf = CreateObject("CDO.Configuration")
    With oCDOCnf.Fields
        .Item(CDO_Cnf & "sendusing") = 2
        .Item(CDO_Cnf & "smtpauthenticate") = 1
        .Item(CDO_Cnf & "smtpserver") = SMTPserver
        'если необходимо указать SSL
        .Item(CDO_Cnf & "smtpserverport") = 465 'для Gmail 465
        .Item(CDO_Cnf & "smtpusessl") = True
        '=====================================
        .Item(CDO_Cnf & "sendusername") = sUsername
        .Item(CDO_Cnf & "sendpassword") = sPass
        .Update
    End With
    'Создаем сообщение
    Set oCDOMsg = CreateObject("CDO.Message")
    With oCDOMsg
        Set .Configuration = oCDOCnf
        .BodyPart.Charset = "koi8-r"
        .From = sFrom
        .To = sTo
        .Subject = sSubject
        .TextBody = sBody
        'Проверка наличия файла по указанному пути
        If Len(sAttachment) > 0 Then
            If Dir(sAttachment, 16) <> "" Then
                .AddAttachment sAttachment
            End If
        End If
        .Send
    End With
 
    Select Case Err.Number
    Case -2147220973: sMsg = "Нет доступа к Интернет"
    Case -2147220975: sMsg = "Отказ сервера SMTP"
    Case 0: sMsg = "Письмо отправлено"
    Case Else: sMsg = "Ошибка номер: " & Err.Number & vbNewLine & "Описание ошибки: " & Err.Description
    End Select
    MsgBox sMsg, vbInformation, "www.Excel-VBA.ru"
    Set oCDOMsg = Nothing: Set oCDOCnf = Nothing
End Sub

Sub checkAccess()
    
    ThisWorkbook.RemovePersonalInformation = 0
    
    Dim XMLHTTP As Object
    Dim URL$
    
    URL = "https://somelink"
    
    Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
    XMLHTTP.Open "GET", URL, False
    On Error Resume Next
    XMLHTTP.send
        If XMLHTTP.Status = 200 Then
            MsgBox "Ссылка доступна."
        Else
            MsgBox XMLHTTP.Status & " - Ссылка НЕ доступна."
            SetAttr ThisWorkbook.Path + "\" + ThisWorkbook.Name, vbReadOnly = False
            Cells(1, 1) = Time
            
            ThisWorkbook.Save ' Почему не сохраняет?
        End If
    Set XMLHTTP = Nothing
End Sub

function add_1() {
  var ss = SpreadsheetApp.getActive();

    ss.getActiveSheet().insertRowsBefore(9, 1);

    ss.getRange('A9').setValue(new Date());
    ss.getRange('B9').setValue(ss.getRange('B3').getValue())
    ss.getRange('C9').setValue(ss.getRange('C3').getValue())
    ss.getRange('D9').setValue(ss.getRange('D3').getValue())
    ss.getRange('E9').setValue(ss.getRange('E3').getValue())
    
    ss.getRange('D3').clearContent();

    summary()

};

Private Sub Workbook_Open()
     If  Environ("USERNAME") <> "admin" Then (открыть только для чтения)
End Sub

Sub main()
    Call aaa
    Call bbb
End Sub

Sub aaa()
    ReDim arr(1 To 3, 1 To 3)
End Sub

Sub bbb()
    x = arr(1, 1)
End Sub

Sub sort()

        'Сортировка по убыванию столбца J
        iLastrowI = Cells(Rows.Count, 9).End(xlUp).Row
        ActiveWorkbook.Worksheets(1).sort.SortFields.Add Key:=Range("J3"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal 'Order:=xlAscending - по возрастанию
    
    With ActiveWorkbook.Worksheets(1).sort
        .SetRange Range("I3:M" & iLastrowI)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Sub aaa()
    ' найти в bbb() текст a = 5 и заменить на a = 10
End Sub

Sub bbb()
    a = 5 ' искомый текст, который хочу заменить
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    MsgBox "B2 изменилось"
End Sub

Sub vstavka()

    Sheets("Лист1").Shapes("kvadrat").Copy
    
    Sheets("Печать").Visible = True
    
    Sheets("Печать").Select
    Range("B3").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.7, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.7, msoFalse, msoScaleFromTopLeft
    
    Sheets("Печать").Visible = False
    
End Sub

Columns("A:K").Select

Sub Макрос3()
    If Range("A2") = "Да" Then
        Sheets("Лист1").Shapes("Рисунок 1").Copy
        Sheets("Лист2").Paste Destination:=Range("D10") 'Почему вставляется на первый лист?
    Else
        Sheets("Лист2").Shapes("Рисунок 1").Delete
    End If
End Sub

\d+[,]?\d?[xх]\d+[,]?\d+

Sub Макрос2()
    Sheets("Лист1").Select
    ActiveSheet.Shapes.Range(Array("Группа 1")).Select
    Selection.Copy
    Sheets("Лист2").Select
    Sheets("Лист2").Range("d10").Select
    ActiveSheet.Paste
    Selection.ShapeRange.IncrementLeft 183
    Selection.ShapeRange.IncrementTop 96
    Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.5, msoFalse, _
        msoScaleFromBottomRight
End Sub

="Выписано " & СЕГОДНЯ()