With Sheets("a2")
With .Range("A1:B5")
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -0.149998474074526
End With
End With

With Sheets("a2")
With .Range(Cells(1, 1), Cells(5, 5))
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -0.149998474074526
End With
End With

Global di As Object
Sub test4()
di = "ssn": Call sd
End Sub
Sub sd()
Set di = CreateObject("Scripting.Dictionary")
End Sub

'запускаем exe
p = "C:\Users\XXX\Desktop"
    Call Shell(p & "\XXX.exe")
    Application.Wait (Now + TimeValue("0:00:05"))
        
'активируем окно exe
    AppActivate ("XXX")
'нажимаем TAB, Enter
    SendKeys "{TAB 1}", True
    Debug.Print "tab"
    Application.Wait (Now + TimeValue("0:00:05"))
    
    SendKeys "{Enter 1}", True
    Debug.Print "enter"
    Application.Wait (Now + TimeValue("0:00:05"))
'курсор на окне "обзор" вбиваем в него путь к файлу
    SendKeys p & "\XXX.xlsx", True
    Application.Wait (Now + TimeValue("0:00:05"))
 
'нажимаем TAB, Enter
    SendKeys "{Enter 1}", True
    Debug.Print "enter"
    Application.Wait (Now + TimeValue("0:00:05"))
    
    AppActivate ("XXX")
    Application.Wait (Now + TimeValue("0:00:05"))
    
    SendKeys "{Enter 1}", True
    Debug.Print "enter"
    Application.Wait (Now + TimeValue("0:00:05"))
    
    SendKeys "{TAB 1}", True
    Debug.Print "tab"
    Application.Wait (Now + TimeValue("0:00:05"))
    
    SendKeys "{Enter 1}", True
    Debug.Print "enter"
    Application.Wait (Now + TimeValue("0:00:05"))

If a Like "*.xlsx" Then

Sub Ïåðâîå_MailSave1()
    Dim oOutlook As Object ' New Outlook.Application
    Dim oNamespace As Object 'Outlook.Namespace
    Dim myFolder As Object 'Outlook.Folder
    Dim myMail As Object 'Outlook.Items
    Dim myItem As Object 'Outlook.MailItem
Dim ad As String
t = ActiveWorkbook.Path

 Set oOutlook = GetObject(, "outlook.Application")
  
        Set oNamespace = oOutlook.GetNamespace("MAPI")
        Set myFolder = oNamespace.GetDefaultFolder(6)
        Set myMail = myFolder.Items
 
 
        For Each myItem In myMail
            On Error Resume Next
                    
        'If myItem.Subject = "1" Then
        If myItem.Attachments(1).Count <> 0 And myItem.Attachments(1).Name = "11111.xlsx" Then
        Debug.Print "a=" & myItem.Attachments(1)
        Debug.Print "s=" & myItem.Subject
        End If
        Next
End Sub

Private Sub Form_Load()
 MyPath = "C:\1"
 Set WshShell = CreateObject("WScript.Shell")
 WshShell.CurrentDirectory = MyPath
 Call Shell("1.exe")
 
 End Sub

Sub Macro4()
Dim a5pop As Object
 Set a5pop = CreateObject("Scripting.Dictionary")
 
 
If a5pop.keys()(0) = "" Then Debug.Print "Nothing"
'If a5pop <> Nothing Then Debug.Print "Not Nothing"

End Sub

Sub countt()
Dim Vv()
Dim a As Range
Sheets("sheet2").Select
Vv = Sheets("sheet2").Range(Cells(1, 1), Cells(10, 10)).Value

Sheets("sheet1").Cells(1, 1).Resize(1, 10) = Vv
Sheets("sheet1").Select
Set a = Sheets("sheet1").Range(Cells(1, 1), Cells(1, 6))

b = 4
s = WorksheetFunction.CountIf(a, b)
Debug.Print s
End Sub

       With Sheets("Vvod dannyh").Range(Cells(5, 1), Cells(5, 9)).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With

Sub Macro3()
Dim found As Range
'удаляю следы предыдущего веселья
Sheets("ch5").Select
Selection.Clear

'начинаю цикл по искомым значениям из листа а5
For c55 = 1 To 2

'ищу все значения в листе ch2
b30 = Sheets("a5").Cells(c55 + 3, 4).Value
Sheets("ch2").Select
Set found = Sheets("ch2").Range(Cells(1, 1), Cells(10000, 10000)).Find(What:=b30, After:=Cells(1, 1), LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)

b31 = found.Row
b32 = found.Column
b33 = 0
b34 = 0
h1 = 1
Do Until b31 = b33 And b32 = b34
Sheets("ch2").Select
Set found = Sheets("ch2").Cells.FindNext(After:=found)
'определяю положение найденного на листе
b33 = found.Row
b34 = found.Column
'копирую строку с найденным значением, но только ДО найденного значения
Sheets("ch2").Select
Range(Cells(b33, 1), Cells(b33, b34)).Select
Selection.Copy
Sheets("ch5").Select
Cells(h1, 1).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveSheet.Paste
h1 = h1 + 1
Loop

Sheets("ch5").Select
MsgBox (c55)

'удаляю совпадения
Dim lCol As Long, lr As Long
Dim arr()
lr = Sheets("ch5").UsedRange.Row + Sheets("ch5").UsedRange.Rows.Count - 1
lCol = Sheets("ch5").UsedRange.Column + Sheets("ch5").UsedRange.Columns.Count - 1
ReDim arr(0 To lCol - 1)
For li = 1 To lCol
    arr(li - 1) = li
Next li
Range("A1").Resize(lr, lCol).RemoveDuplicates arr, xlNo
Next c55
End Sub

c1 = 5
Do While Sheets("Vvod dannyh").Cells(c1, 2).Value <> ""
If Sheets("Vvod dannyh").Cells(c1, 4).Value = Sheets("Vvod dannyh").Cells(c1 - 1, 4).Value And Sheets("Vvod dannyh").Cells(c1, 3).Value = Sheets("Vvod dannyh").Cells(c1 - 1, 3).Value And Sheets("Vvod dannyh").Cells(c1 + 1, 3).Value = "" Then
Sheets("Vvod dannyh").Select
Sheets("Vvod dannyh").Rows(c1).Select
Selection.EntireRow.Delete
End If
c1 = c1 + 1
Loop

Sub Outlook()
Dim mli As MailItem
Dim flr As Outlook.MAPIFolder
On Error Resume Next
For Each mli In flr.Items
If mli.Subject = "Ïðèâåò" Then
mli.Attachments.Open
End If
Next
End Sub

   Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="C:\Users\aaa\Desktop\1\123.xlsm"

Dim sh As Worksheet, sha As Shape
For Each sh In ThisWorkbook.Worksheets
sh.Visible = True
Next sh

Sheets("2").Select
Range("A1").Select

Sub Supersub()
For j = 1 To 22
Sheets("Sheet1").Select
Sheets("Sheet1").Cells(j, 1).Value = "Sub F" & j
Next j
End Sub

Sub TestFindAll()
    
    Dim SearchRange As Range
    Dim FindWhat As Variant
    Dim FoundCells As Range
    Dim FoundCell As Range
    
    Set SearchRange = Range("A1:A10")
    FindWhat = 77
    Set FoundCells = FindAll(SearchRange:=SearchRange, _
                            FindWhat:=FindWhat, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            MatchCase:=False, _
                            BeginsWith:=vbNullString, _
                            EndsWith:=vbNullString, _
                            BeginEndCompare:=vbTextCompare)
    If FoundCells Is Nothing Then
        Debug.Print "Value Not Found"
    Else
        For Each FoundCell In FoundCells
            Debug.Print "Value Found In Cell: " & FoundCell.Address(False, False)
        Next FoundCell
    End If
End Sub

    Range("A1:CRR5000").Select
    ActiveSheet.Range("$A$1:$CRR$5000").RemoveDuplicates Columns:=Array(1, 2, 3), Header _
        :=xlNo