= Table.TransformColumnTypes(РазвернутыСтолбцы, List.Transform(РазвернутыСтолбцы, Value.Type(табValueType)))

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
Application.EnableCancelKey = xlDisabled
Application.EnableEvents = False
Cancel = True
    
    Dim fName As Variant
    Dim FileFormatValue As Long

    With Application
        fName = .GetSaveAsFilename(InitialFileName:=ActiveWorkbook.Name, FileFilter:=" Excel Binary Workbook (*.xlsb), *.xlsb", FilterIndex:=1, Title:="Save as .xlsb")
    End With

    ' Find the correct FileFormat that matches the choice
    ' in the "Save as type" list.
    Select Case getExtension(fName)
        Case "xlsb": FileFormatValue = 50 'xlExcel12 '50
        Case Else: FileFormatValue = 50
    End Select

    If fName = False Then GoTo NotSaved ' When user selects Cancel.

    On Error Resume Next
    'Exit Sub

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fName, FileFormat:=FileFormatValue, CreateBackup:=False

'DoEvents
    If Err.Number <> 0 Then
        On Error GoTo 0
        GoTo NotSaved
    Else
        On Error GoTo 0
        'MsgBox "Project successfully saved.", vbInformation ' Exit Sub '
    End If
        
        
Application.EnableCancelKey = xlInterrupt
    Exit Sub '

NotSaved:
    
    'MsgBox "Project Not Saved!", vbExclamation ' Exit Sub '

    ActiveWorkbook.Activate
Application.EnableCancelKey = xlInterrupt
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.EnableCancelKey = xlDisabled
Application.EnableEvents = False
    Dim fName As Variant
    Dim FileFormatValue As Long

    With Application
        fName = .GetSaveAsFilename(InitialFileName:=ActiveWorkbook.Name, FileFilter:=" Excel Binary Workbook (*.xlsb), *.xlsb", FilterIndex:=1, Title:="Save as .xlsb")
    End With

    ' Find the correct FileFormat that matches the choice
    ' in the "Save as type" list.
    Select Case getExtension(fName)
        Case "xlsb": FileFormatValue = 50 'xlExcel12 '50
        Case Else: FileFormatValue = 50
    End Select

    If fName = False Then GoTo NotSaved ' When user selects Cancel.

    On Error Resume Next
    'Exit Sub

ActiveWorkbook.SaveAs fName, FileFormat:=FileFormatValue, CreateBackup:=False

'DoEvents
    If Err.Number <> 0 Then
        On Error GoTo 0
        GoTo NotSaved
    Else
        On Error GoTo 0
        'MsgBox "Project successfully saved.", vbInformation ' Exit Sub '
    End If
        
        
Application.EnableCancelKey = xlInterrupt
    Exit Sub '

NotSaved:
    
    'MsgBox "Project Not Saved!", vbExclamation ' Exit Sub '

    ActiveWorkbook.Activate
Application.EnableCancelKey = xlInterrupt
Application.EnableEvents = True
End Sub

Function getExtension(ByVal fName As String) As String
    getExtension = LCase(Right(fName, Len(fName) - InStrRev(fName, ".")))
End Function

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    
    Dim fName As Variant
    Dim FileFormatValue As Long

    With Application
        fName = .GetSaveAsFilename(InitialFileName:=ActiveWorkbook.Name, FileFilter:=" Excel Binary Workbook (*.xlsb), *.xlsb", FilterIndex:=1, Title:="Save as .xlsb")
    End With

    ' Find the correct FileFormat that matches the choice
    ' in the "Save as type" list.
    Select Case getExtension(fName)
        Case "xlsb": FileFormatValue = 50
        Case Else: FileFormatValue = 0
    End Select

    If fName = False Then GoTo NotSaved ' When user selects Cancel.

    On Error Resume Next
    'Exit Sub
    ActiveWorkbook.SaveAs fName, FileFormat:=FileFormatValue, CreateBackup:=False

    If Err.Number <> 0 Then
        On Error GoTo 0
        GoTo NotSaved
    Else
        On Error GoTo 0
        Exit Sub 'MsgBox "Project successfully saved.", vbInformation
    End If
    
    Exit Sub '

NotSaved:    
    Exit Sub 'MsgBox "Project Not Saved!", vbExclamation
End Sub

    Dim ВыкладкаФайлы As Variant
           
Sheets("Генератор").Select
          
lLastRow = Sheets("Генератор").Cells(Rows.Count, 19).End(xlUp).Row
Sheets("Генератор").Range(Cells(1, 19), Cells(lLastRow, 19)).Select
ВыкладкаФайлы = Selection.Value2

For Each Filename In ВыкладкаФайлы ' здесь Run-time error '13': Type mismatch
Debug.Print Filename

% Доля товара в Адресе = 
DIVIDE(
CALCULATE(
    SUM('_Товародвижение Куб'[Прибыль]);
    FILTER(
        ALL('_Товародвижение Куб');
        '_Товародвижение Куб'[Прибыль]>=EARLIER('_Товародвижение Куб'[Прибыль])
)) ; SUM('_Товародвижение Куб'[Прибыль]); 
BLANK())

Application.CommandBars("Queries and Connections").Visible = True
Application.CommandBars("Queries and Connections").Width = 300

Application.CommandBars("Workbook Queries").Enabled = True

let   fx=(txt as text, regex as text, delim as text)=>
    Web.Page(
        "<script>
            var x = '" & txt & "';
            var delim = '" & delim & "';
            var pattern = /" & regex & "/gi;
            var result = x.match(pattern).join(delim);
            document.write(result);
        </script>")[Data]{0}[Children]{0}[Children]{1}[Text]{0}
in
fx

УдаленыСтолбцыМатр = Table.RemoveColumns(ЧистыеНаимСтолбцов, List.Select(Table.ColumnNames(ЧистыеНаимСтолбцов), each Text.Contains(_, "матр"))),

Private Sub Worksheet_Change(ByVal Target As Range)
'On Error Resume Next
Worksheets(1).Activate
If Intersect(Target, Worksheets(1).Range(Cells(4, 6))) Is Nothing Then Exit Sub
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
Application.StatusBar = False

ActiveWorkbook.RefreshAll

Private Sub
Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

'Update 20141110     Sub RemoveIndicatorShapes()

'Dim pWs As Worksheet
'Dim pShape As Shape

Dim pWs As Worksheet
Dim pComment As Comment
Dim pRng As Range
Dim pShape As Shape

Set pWs = Application.ActiveSheet

For Each pShape In pWs.Shapes
    If Not pShape.TopLeftCell.Comment Is Nothing Then     'в этой строке дебаг дает желтую подсветку 
      If pShape.AutoShapeType = msoShapeRightTriangle Then
        pShape.Delete
      End If
    End If
Next

Sub RefreshAllPivotTables()
    t = Timer
Dim PT As PivotTable
Dim WS As Worksheet
    For Each WS In ThisWorkbook.Worksheets
        For Each PT In WS.PivotTables
          PT.RefreshTable
        Next PT
    Next WS
    MsgBox "???" & Chr(10) & "???:  " & TimeSerial(0, 0, (Timer - t)) & " ???.", vbInformation + vbMsgBoxSetForeground + vbSystemModal
End Sub

Sub ВыбратьФайлы()
    t = Timer
Dim vFolders(), lCount As Long
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim sFolder As String, sFiles As String

     With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы выгрузок 1С" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
'       .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - xls files(Текстовые файлы)
        .InitialFileName = ActiveWorkbook.Sheets("БД").Range("B2").Value ' = sFolder С:\Temp\Книга1.xlsx" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = False Then Exit Sub
        For lf = 1 To .SelectedItems.Count
            X = .SelectedItems(lf) 'считываем полный путь к файлу
            Workbooks.Open X 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
            ТиповойФайл

' ? открытие остальных файлов папки
' ? постановка отметки о неучастии в массиве
' ? выход с сохранением

        Next
    End With
    Application.ScreenUpdating = True
MsgBox "Обновлены остатки" & Chr(10) & Chr(10) & "Первичная дата выгрузки: " & ActiveWorkbook.Sheets("БД").Range("J1").Value & Chr(10) & Chr(10) & "Готово за:  " & TimeSerial(0, 0, (Timer - t)) & " сек.", vbInformation + vbMsgBoxSetForeground + vbSystemModal
End Sub

Private Sub Application_Startup()
Call Module2.TimerStart
End Sub


Public Sub Syn()
    Dim nsp As Outlook.NameSpace
    Dim sycs As Outlook.SyncObjects
    Dim syc As Outlook.SyncObject
    Dim i As Integer
    Dim strPrompt As Integer
    Set nsp = Application.GetNamespace("MAPI")
    Set sycs = nsp.SyncObjects
    For i = 1 To sycs.Count
        Set syc = sycs.Item(i)
        strPrompt = vbYes
        If strPrompt = vbYes Then
            syc.Start
        End If
    Next
End Sub

Option Explicit
Dim iTmr As LongLong

Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As LongLong, ByVal nIDEvent As LongLong, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongLong) As LongLong
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongLong, ByVal nIDEvent As LongLong) As LongLong
 
Public Sub TimerStart()
'''    If iTmr Then KillTimer 0, iTmr  'Убить старый таймер 'Отлично работает однократно
'''    iTmr = SetTimer(0, 0, 15000, AddressOf TimerProc)

    If iTmr Then TimerProc  ''Отлично работает каждую минуту с момента запуска
    iTmr = SetTimer(0, 0, 60000, AddressOf TimerProc)

End Sub
 
Sub EndTimer()
   iTmr = KillTimer(0, iTmr)
End Sub
 
Private Sub TimerProc()
    On Error GoTo errr
'Call EndTimer
Call ThisOutlookSession.Syn
errr:
End Sub

Sub qqq()
 Dim Uniq As New Collection, LastRow As Long, i As Long, j As Long, iValue, Arr(), Arr2(), x
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Arr = Range(Cells(2, 1), Cells(LastRow, 1)).Value
    For i = 1 To UBound(Arr, 1)
        On Error Resume Next
        Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
    Next
    ReDim Arr2(1 To Uniq.Count, 1 To 2)
    x = 1
    For i = 1 To Uniq.Count
        iValue = Uniq(i)
        For j = 1 To UBound(Arr, 1)
            If Arr(j, 1) = iValue Then
                Arr2(x, 1) = iValue
                Arr2(x, 2) = i '+ 1
                x = x + 1
                Exit For
            End If
        Next
    Next
[E2].Resize(x - 1, 2) = Arr2
End Sub

Sub Макрос1_FSOCopyFolder()
On Error Resume Next
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFolder "D:\откуда\*", "D:\куда\", 0
End Sub