Option Explicit

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long _
) As Long
Private Declare Function GetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function SetFileTime Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpCreationTime As FILETIME, _
    lpLastAccessTime As FILETIME, _
    lpLastWriteTime As FILETIME _
) As Long
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
) As Long
Private Declare Function SetFileAttributes Lib "kernel32.dll" Alias "SetFileAttributesA" ( _
    ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long _
) As Long

Private Const _
    GENERIC_WRITE& = &H40000000, _
    GENERIC_READ = &H80000000, _
    OPEN_EXISTING& = 3

Private Sub CommandButton1_Click()
    Dim strFolder$
    Dim CreationTime As FILETIME, _
        LastAccessTime As FILETIME, _
        LastWriteTime As FILETIME
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then strFolder = .SelectedItems(1) Else Exit Sub
    End With
    Dim coll As Collection, strFilePath, strNewFilePath$, hFile&, hFileAttr&
    Dim DocProp(1 To 6) As Variant, objTimeZone As Object, zip$, TZOffset#
    Set coll = FilenamesCollection(strFolder, ".doc")
    Application.ScreenUpdating = False
    For Each strFilePath In coll
        'создаем файловый дескриптор, указывающий на исходный файл
        hFile = CreateFile(strFilePath, GENERIC_READ, 0&, 0&, OPEN_EXISTING, 0&, 0&)
        'читаем датувремя создания, открытия, сохранения файла
        GetFileTime hFile, CreationTime, LastAccessTime, LastWriteTime
        hFileAttr = GetFileAttributes(strFilePath)
        'закрываем дескриптор
        CloseHandle hFile
        With Documents.Open(strFilePath)
            strNewFilePath = Left(.FullName, InStrRev(.FullName, ".")) & "docx"
            'этот блок нужен для переноса встроенных свойств файла
            '7-last author,8=revision number,9-application name,11-creation date
            '12-last save time,13-total editing time
            With .BuiltInDocumentProperties
                DocProp(1) = .Item(7): DocProp(2) = .Item(8)
                DocProp(3) = .Item(9): DocProp(4) = .Item(11)
                DocProp(5) = .Item(12): DocProp(6) = .Item(13)
            End With
            .SaveAs strNewFilePath, 12: .Convert: .Save
            .Close: 'Kill strFilePath 'удаление исходного файла
        End With
        'определяем часовой пояс
        With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
            For Each objTimeZone In .ExecQuery("Select * from Win32_TimeZone")
                TZOffset = objTimeZone.Bias / 1440
            Next
        End With
        'заменяем встроенные свойства скопированного файла
        zip = "%ProgramFiles(x86)%\7-Zip\7z.exe"
        With CreateObject("wscript.shell")
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ x """ & strNewFilePath & """ docProps\app.xml -y""", 0, 1
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ x """ & strNewFilePath & """ docProps\core.xml -y""", 0, 1
            With CreateObject("MSXML2.DOMDocument.4.0")
                .async = False: .validateOnParse = False
                .Load Environ("tmp") & "\docProps\core.xml"
                .setProperty "SelectionLanguage", "XPath"
                .setProperty "SelectionNamespaces", _
                    "xmlns:cp='http://schemas.openxmlformats.org/package/2006/metadata/core-properties' " & _
                    "xmlns:dc='http://purl.org/dc/elements/1.1/' " & _
                    "xmlns:dcterms='http://purl.org/dc/terms/' " & _
                    "xmlns:dcmitype='http://purl.org/dc/dcmitype/' " & _
                    "xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'"
                .SelectSingleNode("//cp:lastModifiedBy").Text = DocProp(1)
                .SelectSingleNode("//cp:revision").Text = DocProp(2)
                .SelectSingleNode("//dcterms:created").Text = _
                    Format(DocProp(4) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
                .SelectSingleNode("//dcterms:modified").Text = _
                    Format(DocProp(5) - TZOffset, "yyyy-mm-ddTHH:MM:SSZ")
                .Save Environ("tmp") & "\docProps\core.xml"
            End With
            With CreateObject("MSXML2.DOMDocument.3.0")
                .async = False: .validateOnParse = False
                .Load Environ("tmp") & "\docProps\app.xml"
                .SelectSingleNode("//Application").Text = DocProp(3)
                .SelectSingleNode("//TotalTime").Text = DocProp(6)
                .Save Environ("tmp") & "\docProps\app.xml"
            End With
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ u """ & strNewFilePath & """ docProps\app.xml -y""", 0, 1
            .Run "%comspec% /c ""cd """ & Environ("tmp") & """&&""" & zip & _
                """ u """ & strNewFilePath & """ docProps\core.xml -y""", 0, 1
            Kill Environ("tmp") & "\docProps\*.*"
            RmDir Environ("tmp") & "\docProps"
        End With
        'создаем файловый дескриптор, указывающий на конвертированный файл
        hFile = CreateFile(strNewFilePath, GENERIC_WRITE, 0&, 0&, OPEN_EXISTING, 0&, 0&)
        'заменяем датувремя создания, открытия, сохранения файла
        SetFileTime hFile, CreationTime, LastAccessTime, LastWriteTime
        SetFileAttributes strNewFilePath, hFileAttr
        'закрываем дескриптор
        CloseHandle hFile
    Next
    Application.ScreenUpdating = True
End Sub

Function ЦБР(Optional ByVal Curr$ = "USD", Optional ByVal dDate As Date) As Currency
    Dim date_req$
    With CreateObject("msxml.DOMDocument")
        date_req = "?date_req=" & IIf(dDate, dDate, Date): .async = 0
        If .Load("http://www.cbr.ru/scripts/XML_daily.asp" & date_req) Then
            With .SelectSingleNode("*/Valute[CharCode='" & UCase(Curr) & "']")
                ЦБР = CCur(.ChildNodes(4).Text) / Val(.ChildNodes(2).Text)
            End With
        End If
    End With
End Function

=ЗАМЕНИТЬ(E4;7;ПОИСК(" ";E4;6)-7;)+C4*D4*7

Private Sub CommandButton1_Click()
    Dim coll As Collection, strFolder As String, strFilePath
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show Then strFolder = .SelectedItems(1)
    End With
    Set coll = FilenamesCollection(strFolder, ".doc")
    Application.ScreenUpdating = False
    For Each strFilePath In coll
        With Documents.Open(strFilePath)
            .SaveAs2 Left(.FullName, InStrRev(.FullName, ".")) & "docx", 12
            .Close
            Kill strFilePath 'удаление исходного файла
        End With
    Next
    Application.ScreenUpdating = True
End Sub

MsgBox a(ii, 1)

Sub Пробирка()
    Dim rng As Range, a As Variant
    Set rng = Range("A1:A100")
    With Application
        a = Evaluate(Join(Array("IF(ISBLANK(", "),"""",ROW(", "))"), rng.Address(, , .ReferenceStyle)))
        a = .Index(rng.Value, .Small(a, Evaluate("ROW(R1:R" & .Count(a) & ")")))
    End With
    MsgBox UBound(a)
    Erase a
    Set rng = Nothing
End Sub

Private Sub ToggleButton1_Click()
    CreateObject("wscript.shell").Run "devcon" & _
        IIf(Len(Environ("PROGRAMFILES(X86)")), 64, "") & " " & _
        IIf(ToggleButton1.Value, "en", "dis") & "able gencdrom", 0, 1
    ToggleButton1.Caption = "Приводы в" & IIf(ToggleButton1.Value, "", "ы") & "ключены"
End Sub

Private Sub Document_Open()
    Dim tbl As Table
    For Each tbl In Me.Tables
        tblrRows(1).HeadingFormat = True
    Next
End Sub

Public WithEvents App As Word.Application
Private Sub App_DocumentBeforePrint(ByVal Doc As Document, Cancel As Boolean)
    Dim tbl As Table
    If Doc Is ThisDocument Then
        For Each tbl In Doc.Tables
            tbl.Rows(1).HeadingFormat = True
        Next
    End If
End Sub

Public objAppWord As New clsAppWord
Sub AutoOpen()
    Set objAppWord.App = Parent
End Sub

=СЧЁТ(ИНДЕКС(1/(ПРОМЕЖУТОЧНЫЕ.ИТОГИ(4;СМЕЩ($A$4:$A$6;;$A$3:$AD$3-1;))=$A$4:$AD$6);СТРОКА(AE1);))

=СУММПРОИЗВ(Ч(ПРОМЕЖУТОЧНЫЕ.ИТОГИ(4;СМЕЩ($A$4:$A$6;;$A$3:$AD$3-1;))=$A4:$AD4))

ЕЧЁТН(МУМНОЖ(ОТБР(A1;{2;3})*1000;{-1:1}))