Sub uble_rem2()
   Dim Папка$, Имя$
   Dim wb As Workbook
   Dim smallrng As Range
   Dim WS_Count As Integer
   Dim lRow As Long
Dim T As Integer
 
   Application.ScreenUpdating = False
  
   Папка = "C:\TMP1" & "\"
   
      Имя = Dir(Папка & "*.xls")
      
   Do While Имя <> ""
   file = Папка & Имя
   Workbooks.Open file, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, UpdateLinks:=True
 WS_Count = ActiveWorkbook.Worksheets.Count
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:Z" & lRow).RemoveDuplicates Array(1, 2, 26)
 
wb.Sheets(1).Activate
    ActiveWorkbook.Save
    ActiveWorkbook.Close
      Имя = Dir
   Loop
   Application.ScreenUpdating = True
End Sub

Sub sum()
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim s As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
       s = 0
       j = i
              Do While Cells(j, 1) = Cells(i, 1)
                  s = s + Cells(j, 2)
        j = j + 1
        If i = LastRow + 1 Then GoTo en
         Loop
                 Cells(j - 1, 4) = s
             Next i
en:
End Sub

Sheets(1).Cells(i, 33) = Sheets(1).Cells(i, 33) +Application.Index(Sheets(3).Range("K4:K" & j), Application.Match(Range("A" & i).Value, Sheets(3).Range("L4:L" & j), 0))

s = Application.Index(Sheets(3).Range("K4:K" & j), Application.Match(Range("A" & i).Value, Sheets(3).Range("L4:L" & j), 0))


If s = "#Н/Д" Then
Sheets(1).Cells(i, 33) = Sheets(1).Cells(i, 33)
Else
Sheets(1).Cells(i, 33) = Sheets(1).Cells(i, 33) + s
End If

Sub atest_a1()
Application.ScreenUpdating = 0
Dim LastRow As Long
Dim wsSh As Worksheet
Set wsSh = Worksheets("04.01.17")
    For Each wsSh In ActiveWorkbook.Worksheets
        wsSh.Activate
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Selection.AutoFilter
    wsSh.Range("$A$1:$O" & LastRow).AutoFilter Field:=3, Criteria1:="="
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
 Next wsSh
 Application.ScreenUpdating = 1
End Sub

Sub Макрос2()
Dim data_bedin As Date
data_bedin = Application.Evaluate("=IF(DAY(L5)<10,""0"","""")&DAY(L5)&"" ""&IF(MONTH(L5)=1,""січня"",IF(MONTH(L5)=2,""лютого"",IF(MONTH(L5)=3,""березня"",IF(MONTH(L5)=4,""квітня"",IF(MONTH(L5)=5,""травня"",IF(MONTH(L5)=6,""червня"",""""))))))&IF(MONTH(L5)=7,""липня"",IF(MONTH(L5)=8,""серпня"",IF(MONTH(L5)=9, ""вересня"",IF(MONTH(L5)=10,""жовтня"",IF(MONTH(L5)=11,""листопада"",IF(MONTH(L5)=12,""грудня"",""""))))))&"" ""&YEAR(L5)")
End Sub 

Sub a_folder()
Const Month As String = "07.2017\"
Const otchet_data As String = "отчет 25.07"
Const SAVE_FOLDER As String = "D:\temp4\work\" & Month & otchet_data
  If Dir(SAVE_FOLDER) <> "" Then
             MsgBox "Папка найдена", vbYesNo
             Else
             MsgBox "Папка не найдена", vbYesNo, "ошибка"
             End If
End Sub

sub active()
Dim winAPP As Window
       For Each winAPP In Application.Windows
        If winAPP.Caption Like "test*.xls" Then
            winAPP.Activate
            Exit For
        End If
    Next
end sub

Sub activ()
Windows("work.xlsx").Activate
End Sub

Workbooks.Open fileName:= _
        strDirPath & strFileName, UpdateLinks:=False, ReadOnly:=True

Cells(i, 3) = Application.VLookup(Range("E" & i).Value, Sheets(3).Range("B1:F" & j), 3, 0)

Option Compare Text

With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\reestr\reestr_1.txt", Destination:=Range("$A$1"))
        .Name = "reestr_1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1251
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(22, 16, 61, 11)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

LastRow = Sheets(1).Cells(Sheets(1).Rows.Count, 13).End(xlUp).Row
 PartOfName = ActiveWorkbook.ActiveSheet.["М" & LastRow]

Sub move()
Dim OldPath$, NewPath$, Shablon$, OnlyName$
 OldPath = " D:\temp\"
    NewPath = "D:\temp\print\"
    Shablon = "*.xls"
    FileCopy = Dir(OldPath & Shablon, vbReadOnly + vbHidden + vbSystem)
    Do Until OnlyName = ""
        MoveFile OldPath & OnlyName, NewPath & OnlyName
        OnlyName = Dir
    Loop


End Sub

Sub format()
Range("G4").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=OR(ISNUMBER(SEARCH(""кред*"",G4)),ISNUMBER(SEARCH(""дубл*"",G4)))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Interior.ColorIndex = 15
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub

=СЧЁТЕСЛИМН(B:B;"ЗГ1*";C:C;"*")
=СЧЁТЕСЛИМН(B:B;"ЗГ2*";C:C;"*")
=СЧЁТЕСЛИМН(B:B;"ЗГ3*";C:C;"*")

=СУММ(--(ЧАСТОТА(ЕСЛИ(D3:D300="Мастер";ПОИСКПОЗ(C3:C300;C3:C300;));СТРОКА(C3:C300)-1)>0))

saveFolder = "D:\Temp2\" & objAttachments.Item
If Dir(saveFolder, vbDirectory) = "" Then MkDir (saveFolder)

saveFolder = "D:\Temp2\" & objAttachment.FileName

Sub unzip()
    iPath = "D:\Temp\08.11.2016\"
    MyName = Dir(iPath, vbNormal)
    MyName = iPath & MyName
'Do While MyName <> ""
If MyName Like "*.rar" Or MyName Like "*.zip" Or MyName Like "*.7z" Then
    zipApp$ = "D:\Program Files\7-Zip\7z.exe e"
        iArhivName$ = MyName
    adr$ = zipApp$ & " """ & iPath & iArhivName$ & """ """ & iPath & """ "
    RetVal = Shell(adr$, vbHide)
End If
   ' MyName = Dir()
'Loop
End Sub

Sub test_run()
Dim strDirPath, strMaskSearch, strFileName As String
strDirPath = "D:\temp\"
strMaskSearch = "new_123_230516_*.xlsx*"
 strFileName = Dir(strDirPath & strMaskSearch)
 ChDir "D:\temp"
    Workbooks.Open FileName:= _
        strFileName
 End Sub

=ПСТР(A2;ПОИСКПОЗ(10;ЧАСТОТА(СТРОКА(1:999);ЕОШ(-ПСТР(A2&-11^11;СТРОКА($1:$999);1))*СТРОКА(1:999));)-9;9)

Sub save333()
 strPath = "D:\work"
        strFileName = InputBox("Введите название файла", "Ввод даних", "????")
             If strFileName = "" Then Exit Sub
               FileNameXls = strPath & "\" & strFileName & ".xls"
        ActiveWorkbook.SaveCopyAs FileName:=FileNameXls
End Sub