Sub пробег1() 'добавить последнюю колонку
Dim i As Long
Dim m As Long
m = 2
For i = Sheets("BASE").[B1].Column To Sheets("BASE").[NC1].Column Step 1
'For m = 2 To 17157 Step 47
Sheets("DATES").Cells(m, 1).Value = Sheets("BASE").Cells(4, i).Value
    m = m + 47
    If m > 17157 Then Exit For
  'Next
  Next
End Sub

Sub myTransfer()
    Dim yrr As Variant
    yrr = Selection.Value
    
    Dim urr As Variant
    ReDim urr(1 To UBound(yrr, 1), 1 To UBound(yrr, 2))
    
    Dim xx As Long
    Dim yy As Long
    Dim uu As Long
    Dim dt As Date
    
    For yy = 1 To UBound(yrr, 1)
        If Not IsEmpty(yrr(yy, 1)) Then
            If IsDate(yrr(yy, 1)) Then
                dt = DateValue(yrr(yy, 1))
            End If
        Else
            uu = uu + 1
            urr(uu, 1) = dt
            For xx = 2 To UBound(yrr, 2)
                urr(uu, xx) = yrr(yy, xx)
            Next
        End If
    Next
    
    With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(urr, 1), UBound(urr, 2))
        .Value = urr
        .Columns(1).NumberFormat = "[$-419]mmmm yyyy;@"
        .Columns(1).AutoFit
    End With
End Sub

C2    =B2&","&ЕСЛИОШИБКА(ВПР(A2;A3:$C$1048576;3;0);"")
D2    =(СЧЁТЕСЛИМН($A$1:A2;A2)=1)+D1
E2    =ЕСЛИОШИБКА(ИНДЕКС(A:A;ПОИСКПОЗ(СТРОКА(E1);D:D;0));"")
F2    =ЕСЛИОШИБКА(ПСТР(ВПР(E2;A:C;3;0);1;ДЛСТР(ВПР(E2;A:C;3;0))-1);"")

Option Explicit

Private Sub Worksheet_selectionChange(ByVal Target As Range)
    If Target.Cells(1, 1).Value = "Отправить" Then
        myAdd Array(Now, Range("E5").Value, Get2(), Get3(1, 5), Get3(6, 10), Get3(11, 13))
    End If
End Sub

Function Get2() As String
    Dim ss As String
    Dim ob As OptionButton
    For Each ob In ActiveSheet.OptionButtons
        If ob.Value = 1 Then ss = ss & ob.Caption
    Next
    Get2 = ss
End Function

Function Get3(i1 As Long, i2 As Long) As String
    Dim ss As String
    Dim cb As CheckBox
    Dim ii As Long
    For ii = i1 To i2
        Set cb = ActiveSheet.CheckBoxes(ii)
        If cb.Value = 1 Then ss = ss & " " & ii & " " & cb.Caption
    Next
    Get3 = ss
End Function

Sub myAdd(arr As Variant)
    With Sheets("Данные")
        With .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
            With .Resize(1, UBound(arr) - LBound(arr) + 1)
                .Value = arr
            End With
        End With
    End With
    Application.StatusBar = arr(LBound(arr))
End Sub

D2:D11    =D1+(C2<>" ")*(СЧЁТЕСЛИМН($C$1:C2;C2)=1)
E2:E11    =ЕСЛИОШИБКА(ИНДЕКС($C$1:$C$11;ПОИСКПОЗ(СТРОКА(E1);D:D;0));"")

=ЕСЛИОШИБКА(ИНДЕКС($C$1:$C$11;1/(1/НАИБОЛЬШИЙ(($C$2:$C$11<>" ")*(СТРОКА($C$2:$C$11));СТРОКА(E1))));"")

'В модуль листа
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    RangeAdd Target
End Sub

'В стандартный модуль
Sub SelectionAdd()
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim cl As Range
    For Each cl In rr.Cells
         RangeAdd cl
    Next
    
    Application.Calculation = Application_Calculation
End Sub
'В стандартный модуль
Sub RangeAdd(cl As Range)
    If Left(cl.Formula, 1) <> "=" Then
        If IsNumeric(cl.Formula) Then
            cl.Value = cl.Value + 1
        End If
    End If
End Sub

=ЕСЛИОШИБКА(ВПР(B60;$B$1:H59;7;0);"")

Sub SplitColumns()
    Const nROWS = 1700
    
    Dim rInp As Range
    On Error Resume Next
    Set rInp = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rInp Is Nothing Then Exit Sub
    
    Dim rOut As Range
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Dim yy As Long
    For yy = 1 To rInp.Rows.Count Step nROWS
        rInp.Cells(yy, 1).Resize(nROWS, rInp.Columns.Count).Copy rOut
        Set rOut = rOut.Cells(1, rInp.Columns.Count + 2)
    Next
End Sub

=И(D5<>"--";D5<>D4)

=И(D5<>"--";D5<>D6)

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = "A1" Then
        If MaskCompare(Target.Value, "##-##", 1) = False Then
            MsgBox "Введённое значение неверно.", vbCritical
        
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
        End If
    End If
End Sub

Sub test()
    FillRight Range("P26"), 3
    FillLeft Range("P26"), 6
    FillDown Range("P26"), 12
    FillUp Range("P26"), 4
End Sub

Sub FillRight(rr As Range, nn As Long)
    Dim arr As Variant
    ReDim arr(1 To nn)
    Dim yy As Long
    For yy = 1 To nn
        arr(yy) = yy
    Next
    rr.Resize(1, UBound(arr)) = arr
End Sub
Sub FillLeft(rr As Range, nn As Long)
    Dim arr As Variant
    ReDim arr(1 To nn)
    Dim yy As Long
    For yy = 1 To nn
        arr(yy) = nn - yy + 1
    Next
    rr.Offset(0, -nn + 1).Resize(1, UBound(arr)) = arr
End Sub
Sub FillDown(rr As Range, nn As Long)
    Dim arr As Variant
    ReDim arr(1 To nn, 1 To 1)
    Dim yy As Long
    For yy = 1 To nn
        arr(yy, 1) = yy
    Next
    rr.Resize(UBound(arr, 1), 1) = arr
End Sub
Sub FillUp(rr As Range, nn As Long)
    Dim arr As Variant
    ReDim arr(1 To nn, 1 To 1)
    Dim yy As Long
    For yy = 1 To nn
        arr(yy, 1) = nn - yy + 1
    Next
    rr.Offset(-nn + 1, 0).Resize(UBound(arr, 1), 1) = arr
End Sub

=СМЕЩ($G$2;0;(СТОЛБЕЦ()-СТОЛБЕЦ($G$2))*2;1;1)

Dim fso As Object

Sub Посчитать_в_ТТН()
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    Dim yReport As Long
    Dim aReport As Variant
    ReDim aReport(1 To UBound(aFiles), 1 To 3)
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim vFile As Variant
    For Each vFile In aFiles
        yReport = yReport + 1
        JobFile vFile, aReport, yReport
    Next
    If yReport > 0 Then
        With Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(aReport, 1), UBound(aReport, 2))
            .Value = aReport
        End With
    End If
    
    Application.Calculation = Application_Calculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Private Sub JobFile(ByVal sFull, aReport As Variant, yReport As Long)
    Application.StatusBar = Right(sFull, 255)
    Dim wb As Workbook
    On Error Resume Next
    Workbooks(fso.GetFileName(sFull)).Close False
    On Error GoTo 0
    Set wb = Workbooks.Open(sFull, False, True)
    
    aReport(yReport, 1) = WorksheetFunction.CountA(wb.Sheets(1).Range("A18:A25"))
    aReport(yReport, 2) = wb.Name
    aReport(yReport, 3) = sFull
    
    wb.Close False
    Application.StatusBar = False
End Sub

Function ShowFileDialog() As Variant
'    Dim rInitialFileName As Range
'    Set rInitialFileName = ThisWorkbook.Names("шаблон").RefersToRange
    
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\"
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
'                    rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Sub SaveFile()
   'Объявление переменных
   Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String
  
  ActiveSheet.Copy
  
   'Временно отключаем показ вспомогательных сообщений
   Application.DisplayAlerts = False
  
   'Задаём каталог сохранения файла (в данном случае текущий каталог)
   Path = ThisWorkbook.Path & "\"
  
   'Получаем значение ячейки
   CellValue = Range("a7")
  
   'Формируем итоговый путь и название файла
   FinalFileName = Path & CellValue
     
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        sh.Delete
    Next
   
   'Сохраняем файл
   ActiveWorkbook.SaveAs Filename:=FinalFileName, _
                      FileFormat:=xlOpenXMLWorkbook
                      'FileFormat:=xlOpenXMLWorkbookMacroEnabled 'Для сохранения файла с макросом
  
   'Включаем вывод сообщений
   Application.DisplayAlerts = True
  
   'Сообщение с результатом выполнения процедуры
   MsgBox "Файл успешно сохранен с названием - " & CellValue, vbInformation, "Результат"
  
  End Sub

=ЕСЛИ(ЛЕВСИМВ(ПРАВСИМВ(A1;4);3)="/2/";A1;"")

Sub SaveFile()
 
   'Объявление переменных
   Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String
 
   'Временно отключаем показ вспомогательных сообщений
   Application.DisplayAlerts = False
 
   'Задаём каталог сохранения файла (в данном случае текущий каталог)
   Path = ThisWorkbook.Path & "\"
 
   'Получаем значение ячейки
   CellValue = Range("a7")
 
   'Формируем итоговый путь и название файла
   FinalFileName = Path & CellValue
    
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        sh.Delete
    Next
    
   'Сохраняем файл
   ActiveWorkbook.SaveAs Filename:=FinalFileName, _
                      FileFormat:=xlOpenXMLWorkbook
                      'FileFormat:=xlOpenXMLWorkbookMacroEnabled 'Для сохранения файла с макросом
 
   'Включаем вывод сообщений
   Application.DisplayAlerts = True
 
   'Сообщение с результатом выполнения процедуры
   MsgBox "Файл успешно сохранен с названием - " & CellValue, vbInformation, "Результат"
 
  End Sub

Option Explicit
Dim fso As Object
Dim appWord As Object
Dim rOut As Range
    
Sub GetFromWord()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    Set rOut = Workbooks.Add(1).Sheets(1).Cells(1, 1)
    
    Set appWord = CreateObject("Word.Application")
    appWord.Visible = True
    
    Dim vFile As Variant
    For Each vFile In aFiles
        JobWordFile vFile
    Next
    
    appWord.Quit
    Set appWord = Nothing
End Sub

Private Sub JobWordFile(ByVal sFull As String)
    appWord.Documents.Open sFull
    appWord.Selection.WholeStory
    appWord.Selection.Copy
    
    rOut.Parent.Parent.Activate
    rOut.Parent.Activate
    rOut.Select
    With ActiveSheet
        .Paste
        Set rOut = .Cells(.UsedRange.Row + .UsedRange.Rows.Count, 1)
    End With
    
    appWord.ActiveWindow.Close
End Sub

Function ShowFileDialog() As Variant
'    Dim rInitialFileName As Range
'    Set rInitialFileName = ThisWorkbook.Names("шаблон").RefersToRange

    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.doc*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\" 'rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(fso.GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
'                    rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Sub MuggsyBogues()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy = 1 Then Exit Sub
        
        Dim outputRange As Range
        Dim drr As Variant
        Dim nrr As Variant
        Dim mrr As Variant
        Dim prr As Variant
        Dim res As Variant
        
        drr = .Cells(1, "A").Resize(yy)
        nrr = .Cells(1, "C").Resize(yy)
        mrr = .Cells(1, "G").Resize(yy)
        prr = .Cells(1, "H").Resize(yy)
        Set outputRange = .Cells(1, "J").Resize(yy)
        
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        For yy = 2 To UBound(drr, 1)
            dic.Item(nrr(yy, 1)) = dic.Item(nrr(yy, 1)) + 1
        Next
        
        Dim arr As Variant
        Dim irr As Variant
        Dim player As Variant
        Dim uu As Long
        For Each player In dic.Keys
            uu = dic.Item(player)
            ReDim arr(1 To uu, 1 To 3)
            dic.Item(player) = Array(0, arr)
        Next
        For yy = 2 To UBound(drr, 1)
            player = nrr(yy, 1)
            irr = dic.Item(player)
            uu = irr(0) + 1
            arr = irr(1)
            arr(uu, 1) = drr(yy, 1)
            arr(uu, 2) = mrr(yy, 1)
            arr(uu, 3) = prr(yy, 1)
            dic.Item(player) = Array(uu, arr)
        Next
        
        Dim sum1 As Double
        Dim sum2 As Double
        ReDim res(1 To UBound(drr, 1), 1 To 1)
        For yy = 2 To UBound(drr, 1)
            player = nrr(yy, 1)
            irr = dic.Item(player)(1)
            sum1 = 0
            sum2 = 0
            For uu = 1 To UBound(irr, 1)
                If irr(uu, 1) < drr(yy, 1) Then
                    sum1 = sum1 + irr(uu, 2) * irr(uu, 3)
                    sum2 = sum2 + irr(uu, 2)
                End If
            Next
            If sum2 <> 0 Then
                res(yy, 1) = sum1 / sum2
            End If
        Next
        
        outputRange = res
    End With
End Sub

B18:B32    =ВПР(СТРОКА(1:1);W:Y;3;0)
U18:U82    =ЦЕЛОЕ((СТРОКА(1:1)-1)/СЧЁТЗ($C$4:$O$4))
V18:V82    =ОСТАТ(СТРОКА(1:1)-1;СЧЁТЗ($C$4:$O$4))
W18:W82    =W17+(СМЕЩ($B$4;2+U18;1+V18)>0)
X18:X82    =СМЕЩ($B$4;2+U18;-1)
Y18:Y82    =СМЕЩ($B$4;2+U18;0)&ЕСЛИ(X18>1;"_"&X18;"")&", р-р"&СМЕЩ($B$4;0;1+V18)8)

Replace
hwndButton = PostMessage(hwndButton, BM_CLICK, 0, 0)
with
Call SendMessage(hwndButton, WM_LBUTTONDOWN, 0&, ByVal 0&)
Call SendMessage(hwndButton, WM_LBUTTONUP, 0&, ByVal 0&)

If no-go also try replacing the 'Call SendMessage' with 'Call PostMessage' (no other changes needed). Btw, neither of those returns an HWND, so never use hwndButton = with them.

If you need the declares:
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202

=ЕСЛИ(R2="Экспертный";"Экспертный";ЕСЛИ(СЧЁТЕСЛИМН($D3:D$61;D2;$R3:R$61;"Экспертный")>0;"Экспертный";ЕСЛИ(СЧЁТЕСЛИМН($D3:D$61;D2;$R3:R$61;"Высокий")>0;"Высокий";ЕСЛИ(СЧЁТЕСЛИМН($D3:D$61;D2;$R3:R$61;"Базовый")>0;"Базовый";ЕСЛИ(СЧЁТЕСЛИМН($D3:D$61;D2;$R3:R$61;"Ниже базового")>0;"Ниже базового";R2)))))