sub ConvertLongDateToShortDate()
    Dim arr As Variant, arrTemp As Variant
    Dim CountOfSpaces As Long, lDay As Long, lMonthNumber As Long, lYear As Long, i As Long
    Dim Rng As Range
    
    If Selection.Cells.Count = 1 Then
        MsgBox "Выделите диапазон ячеек с датами", vbInformation, "Внимание"
        Exit Sub
    End If
    
    Set Rng = Intersect(Selection, ActiveSheet.UsedRange)
    
    Rng.Replace Chr(160), " "
    
    arr = Rng.Value2
    
    On Error Resume Next
    
    For i = LBound(arr) To UBound(arr)
        If arr(i, 1) <> Empty Then
            If InStr(1, arr(i, 1), " ", vbBinaryCompare) > 0 Then
                CountOfSpaces = Len(arr(i, 1)) - Len(VBA.Replace(arr(i, 1), " ", ""))
                If CountOfSpaces = 2 Then
                    arrTemp = Split(arr(i, 1))
                    If UBound(arrTemp) = 2 Then
                        lMonthNumber = NumberOfMonthName(arrTemp(1))
                        If lMonthNumber > 0 Then
                            arr(i, 1) = DateSerial(CLng(arrTemp(2)), lMonthNumber, CLng(arrTemp(0)))
                        End If
                    End If
                End If
            End If
        End If
    Next i
    
    On Error GoTo 0
    
    Rng.Value = arr
End Sub

Private Function NumberOfMonthName(ByVal Str As String) As Long
    Dim MonthNames As Variant
    MonthNames = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    On Error Resume Next
    NumberOfMonthName = Application.Match(LCase(Str), MonthNames, 0)
End Function

ws.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

Sub CombineWorkbooks()

Dim Path As String
Path = "C:\Users\Am\Desktop\test\"

Dim FileName As String
FileName = Dir(Path & "*.xlsx")

Dim ws As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Do While FileName <> ""
    Workbooks.Open Path & FileName
    For Each ws In ActiveWorkbook.Sheets
        ws.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    Next ws
    Workbooks(FileName).Close
    FileName = Dir()
Loop

Worksheets(1).Delete

Application.ScreenUpdating = False
Application.DisplayAlerts = False

End Sub

Sub TabS()
Application.ScreenUpdating = False
ActiveCell = "Fruits"
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 1)) = "Price"
ActiveCell.Offset(0, 1).Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
Range(ActiveCell.Offset(0, 2), ActiveCell.Offset(0, 2)) = "Quantity"
ActiveCell.Offset(0, 2).Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
Range(ActiveCell.Offset(14, 2), ActiveCell.Offset(14, 2)) = "=SUM(R[-13]C:R[-1]C)"
Range(ActiveCell.Offset(0, 3), ActiveCell.Offset(0, 3)) = "Sum"
ActiveCell.Offset(0, 3).Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
        End With
End With
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 0)) = "Apple"
Range(ActiveCell.Offset(2, 0), ActiveCell.Offset(2, 0)) = "Apricots"
Range(ActiveCell.Offset(3, 0), ActiveCell.Offset(3, 0)) = "Avocado"
Range(ActiveCell.Offset(4, 0), ActiveCell.Offset(4, 0)) = "Banana"
Range(ActiveCell.Offset(5, 0), ActiveCell.Offset(5, 0)) = "Blackberries"
Range(ActiveCell.Offset(6, 0), ActiveCell.Offset(6, 0)) = "Blackcurrant"
Range(ActiveCell.Offset(7, 0), ActiveCell.Offset(7, 0)) = "Breadfruit"
Range(ActiveCell.Offset(8, 0), ActiveCell.Offset(8, 0)) = "Cantaloupe"
Range(ActiveCell.Offset(9, 0), ActiveCell.Offset(9, 0)) = "Cherimoya"
Range(ActiveCell.Offset(10, 0), ActiveCell.Offset(10, 0)) = "Cherries"
Range(ActiveCell.Offset(11, 0), ActiveCell.Offset(11, 0)) = "Clementine"
Range(ActiveCell.Offset(12, 0), ActiveCell.Offset(12, 0)) = "CoconutMeat"
Range(ActiveCell.Offset(13, 0), ActiveCell.Offset(13, 0)) = "Cranberries"

Range(ActiveCell.Offset(14, 0), ActiveCell.Offset(14, 0)) = "Total"
Range(ActiveCell, Cells(ActiveCell.Row + 29, ActiveCell.Column)).Columns.AutoFit
Range(ActiveCell.Offset(1, 1), ActiveCell.Offset(1, 1)) = 2.1
Range(ActiveCell.Offset(2, 1), ActiveCell.Offset(2, 1)) = 3.8
Range(ActiveCell.Offset(3, 1), ActiveCell.Offset(3, 1)) = 6.48
Range(ActiveCell.Offset(4, 1), ActiveCell.Offset(4, 1)) = 11.3
Range(ActiveCell.Offset(5, 1), ActiveCell.Offset(5, 1)) = 22
Range(ActiveCell.Offset(6, 1), ActiveCell.Offset(6, 1)) = 8
Range(ActiveCell.Offset(7, 1), ActiveCell.Offset(7, 1)) = 4.5
Range(ActiveCell.Offset(8, 1), ActiveCell.Offset(8, 1)) = 6.48
Range(ActiveCell.Offset(9, 1), ActiveCell.Offset(9, 1)) = 5.4
Range(ActiveCell.Offset(10, 1), ActiveCell.Offset(10, 1)) = 2.8
Range(ActiveCell.Offset(11, 1), ActiveCell.Offset(11, 1)) = 3
Range(ActiveCell.Offset(12, 1), ActiveCell.Offset(12, 1)) = 14
Range(ActiveCell.Offset(13, 1), ActiveCell.Offset(13, 1)) = 7.89

Application.CutCopyMode = False
Range(ActiveCell.Offset(1, 3), ActiveCell.Offset(1, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(2, 3), ActiveCell.Offset(2, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(3, 3), ActiveCell.Offset(3, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(4, 3), ActiveCell.Offset(4, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(5, 3), ActiveCell.Offset(5, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(6, 3), ActiveCell.Offset(6, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(7, 3), ActiveCell.Offset(7, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(8, 3), ActiveCell.Offset(8, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(9, 3), ActiveCell.Offset(9, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(10, 3), ActiveCell.Offset(10, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(11, 3), ActiveCell.Offset(11, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(12, 3), ActiveCell.Offset(12, 3)) = "=RC[-2]*RC[-1]"
Range(ActiveCell.Offset(13, 3), ActiveCell.Offset(13, 3)) = "=RC[-2]*RC[-1]"

Range(ActiveCell.Offset(14, 3), ActiveCell.Offset(14, 3)) = "=SUM(R[-13]C:R[-1]C)"
ActiveCell.Offset(0, 1).Select
Range(ActiveCell, Cells(ActiveCell.Row + 14, ActiveCell.Column + 2)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
ActiveCell.Offset(0, -1).Select
Range(ActiveCell, Cells(ActiveCell.Row + 14, ActiveCell.Column + 3)).Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    ActiveCell.EntireColumn.AutoFit
    ActiveCell.Offset(0, 1).EntireColumn.AutoFit
    ActiveCell.Offset(0, 2).EntireColumn.AutoFit
    ActiveCell.Offset(0, 3).EntireColumn.AutoFit
Range(ActiveCell.Offset(14, 0), ActiveCell.Offset(14, 1)).Select
        With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
End With
Application.ScreenUpdating = True
End Sub

ProductList = Array("Apple", "Apricots", "Avocado", "Banana", "Blackberries")
PricelcList = Array(2.1 , 3.8,6.48 ,11.3 ,22 )

Function GetRGBTest(Colour As Long, colInd As Integer) As String

Dim Dict As Object

If Colour > 0 Then
    GetRGBTest = "RGB(" & (Colour Mod 256) & "," & ((Colour \ 256) Mod 256) & "," & ((Colour \ 256 \ 256) Mod 256) & ")"
Else
    colInd = LTrim(Str(colInd))
    GetRGBTest = Dict.Item(colInd)
End If
End Function
Sub filtColor()
Dim col As Integer
Dim s As Integer
Dim x As Integer
Dim f As String
x = ActiveSheet.UsedRange.Rows.Count
s = ActiveCell.SpecialCells(xlLastCell).Row
col = ActiveCell.Column
f = GetRGBTest(Selection.Font.Color, Selection.Font.ColorIndex)
MsgBox f
ActiveSheet.Range(Cells(1, 1), Cells(s, col)).AutoFilter Field:=col, Criteria1:=f, Operator:=xlFilterFontColor
End Sub

ActiveSheet.Range(Cells(1, 1), Cells(s, col)).AutoFilter Field:=col, Criteria1:=f, Operator:=xlFilterFontColor

let
    Источник = Excel.Workbook(File.Contents("C:\1.xlsx"), null, true),
    #"Строки с примененным фильтром" = Table.SelectRows(Источник, each ([Item] = "1")),
    #"Удаленные столбцы" = Table.RemoveColumns(#"Строки с примененным фильтром",{"Name", "Item", "Kind", "Hidden"}),
    #"Добавлен пользовательский объект" = Table.AddColumn(#"Удаленные столбцы", "Пользовательский", each Table.FindText([Data],"AZMA")),
    #"Другие удаленные столбцы" = Table.SelectColumns(#"Добавлен пользовательский объект",{"Пользовательский"}),
    #"Развернутый элемент Пользовательский" = Table.ExpandTableColumn(#"Другие удаленные столбцы", "Пользовательский", {"Column1", "Column2", "Column3", "Column4", "Column5"}, {"Column1", "Column2", "Column3", "Column4", "Column5"})
in
    #"Развернутый элемент Пользовательский"

Function GETLASTWORD(ByVal Text As String, Optional Separator As Variant)

Dim lastword As String

If IsMissing(Separator) Then
 Separator = " "
End If
lastword = StrReverse(Text)
lastword = Left(lastword, InStr(1, lastword, Separator, vbTextCompare))

GETLASTWORD = StrReverse(replace(lastword, Separator, ""))

End Function

Sub AddReference()
    Dim VBAEditor As VBIDE.VBE
    Dim vbProj As VBIDE.VBProject
    Dim chkRef As VBIDE.Reference
    Dim BoolExists As Boolean

    Set VBAEditor = Application.VBE
    Set vbProj = ActiveWorkbook.VBProject

    '~~> Check if "Microsoft VBScript Regular Expressions 5.5" is already added
    For Each chkRef In vbProj.References
        If chkRef.Name = "Microsoft Visual Basic for Applications Extensibility 5.3" Then
            BoolExists = True
            GoTo CleanUp
        End If
    Next

    vbProj.References.AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"

CleanUp:
    If BoolExists = True Then
        MsgBox "Reference already exists"
    Else
        MsgBox "Reference Added Successfully"
    End If

    Set vbProj = Nothing
    Set VBAEditor = Nothing
End Sub
 

ActiveCell.FormulaR1C1 = _
        "=IFERROR(VLOOKUP(INDEX(R,0,AGGREGATE(14,6,COLUMN(RC1:OFFSET(RC1,,COLUMN()-COLUMN(RC1)-1))/ISNUMBER(MATCH(RC1:OFFSET(RC1,,COLUMN()-COLUMN(RC1)-1)
,'t.xlsx'!tab10[sell],0)),1)),'t.xlsx'!tab10[#Data],i,0),""нету"")"

Sub Delete_Sub_From_Module()
    Dim lCountLines As Long, li As Long, lStartLine As Long, lProcLineCount As Long
    Dim sCodeName As String, sProcName As String
With ActiveWorkbook.VBProject.VBComponents("Module1") '                            ===>тут начинается ошибка
        'получаем кол-во строк кода в модуле
        lCountLines = .CodeModule.CountOfLines
        'получаем первую строку с кодом, исключая строки декларирования функции и опций модуля
        lStartLine = .CodeModule.CountOfDeclarationLines + 1
        'цикл по всем строкам кода внутри модуля
        For li = lStartLine To lCountLines
            'получаем имя процедуры/функции, внутри которой строка кода
            sProcName = .CodeModule.ProcOfLine(li, 0)
            'если имя процедуры совпадает с тем, которое нам нужно
            If sProcName = "tа234" Then
                'узнаем кол-во строк процедуры/функции
                lProcLineCount = .CodeModule.ProcCountLines(sProcName, 0)
                'удаляем процедуру/функцию
                .CodeModule.DeleteLines li, lProcLineCount - 1
                Exit For
            End If
            li = li + lProcLineCount
        Next li
    End With
End Sub

lLastCol = Cells.SpecialCells(xlLastCell).Column
Range(Cells(1, 1), Cells(1, lLastCol)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
    Selection.FormulaR1C1 = "R[5]C"

Sub SheetsNames()
    Dim i As Integer: ActiveCell.ClearContents
    For i = 1 To Sheets.Count: ActiveCell(i, 1) = Sheets(i).Name: Next
End Sub

Sub Ìàêðîñ2()
Cells.Select
    Selection.Replace What:="1*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="2*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="3*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="4*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="5*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="6*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="7*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="8*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Selection.Replace What:="9*", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End Sub

Sub Format1()
    With ActiveCell
        Range(.Address, Cells(Cells(Rows.Count, .Column).End(xlUp).Row, .Column)).NumberFormat = "#,##0_ ;[Red]-#,##0 "
    End With
End Sub