#If VBA7 Then
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
'Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
' Create custom variable that holds two integers
Type POINTAPI
   Xcoord As Long
   Ycoord As Long
End Type

Sub GetCursorPosDemo()
Dim llCoord As POINTAPI

'=========получим координаты плюсика============================
MsgBox "Встаньте на плюcик, нажмите ENTER"
GetCursorPos llCoord

PlusikX = llCoord.Xcoord
PlusikY = llCoord.Ycoord

'=========получим координаты стрелочки============================
MsgBox "Встаньте на стрелочку, нажмите ENTER"
GetCursorPos llCoord

StrelochkaX = llCoord.Xcoord
StrelochkaY = llCoord.Ycoord

End Sub

' Access the GetCursorPos function in user32.dll
      Declare Function GetCursorPos Lib "user32" _
      (lpPoint As POINTAPI) As Long
      ' Access the GetCursorPos function in user32.dll
      Declare Function SetCursorPos Lib "user32" _
      (ByVal x As Long, ByVal y As Long) As Long

      ' GetCursorPos requires a variable declared as a custom data type
      ' that will hold two integers, one for x value and one for y value
      Type POINTAPI
         X_Pos As Long
         Y_Pos As Long
      End Type

      ' Main routine to dimension variables, retrieve cursor position,
      ' and display coordinates
      Sub Get_Cursor_Pos()

      ' Dimension the variable that will hold the x and y cursor positions
      Dim Hold As POINTAPI

      ' Place the cursor positions in variable Hold
      GetCursorPos Hold

      ' Display the cursor position coordinates
      MsgBox "X Position is : " & Hold.X_Pos & Chr(10) & _
         "Y Position is : " & Hold.Y_Pos
      End Sub

      ' Routine to set cursor position
      Sub Set_Cursor_Pos()

      ' Looping routine that positions the cursor
         For x = 1 To 480 Step 20
            SetCursorPos x, x
            For y = 1 To 40000: Next
         Next x
      End Sub

Option Explicit
Sub GetDataFromTxtFile(TxtFile As String)
      'TxtConn - соединение с БД (в данном случае БД - текстовый файл)
      'TxtRs - набор записей Recordset
    Dim TxtConn As ADODB.Connection
    Dim TxtRs As ADODB.Recordset
      'DBPath - путь к БД
      'ConnStr - строка подключения к БД
      'LastRow - определение последней строки
    Dim DBPath As String
    Dim ConnStr As String
    Dim LastRow As Long
            
    DBPath = ThisWorkbook.Path
    ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBPath & ";Extended Properties='text;HDR=No;FMT=Delimited';"
 
    Set TxtConn = New ADODB.Connection
    Set TxtRs = New ADODB.Recordset
    
    TxtConn.ConnectionString = ConnStr
                               
    TxtConn.Open
      'закрыть соединение в случае ошибки
    On Error GoTo CloseConnection
                                        
    With TxtRs
        .ActiveConnection = TxtConn
          'SQL-запрос к БД
        .Source = "SELECT * FROM " & "[" & TxtFile & "] " & ""
        .LockType = adLockReadOnly
        .CursorType = adOpenForwardOnly
        .Open
    End With
      'закрыть Recordset в случае ошибки
    On Error GoTo CloseRecordset
      'последняя заполненная строка по столбцу "А"
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
      'вставляем Recordset ниже последней заполненной строки
    Range("A" & LastRow + 1).CopyFromRecordset TxtRs
      'отключаем обработку ошибок
    On Error GoTo 0
    
CloseRecordset:
    TxtRs.Close
CloseConnection:
    TxtConn.Close
       
End Sub
Sub GetArrayOfTxtFiles()
      'If (Int(CDbl(Date)) - Int(CDbl(#7/31/2021#))) > 90 Then Exit Sub
      ' TxtFileName - имя обрабатываемого текстового файла
      ' TxtFiles - массив с именами найденных текстовых файлов
      ' FilesCount - счетчик кол-ва найденных текстовых файлов
      ' IsFileAdded - диапазон с именами ранее добавленных текстовых файлов
      '   для проверки на необходимость добавлять TxtFileName
      ' LastRow - последняя заполненная строка
      ' CheckList - лсит с именами ранее добавленных текстовых файлов
      ' i - счетчик
    Dim TxtFileName As String
    Dim TxtFiles() As String
    Dim FilesCount As Integer
    Dim IsFileAdded As Range
    Dim LastRow As Long
    Dim CheckList As Worksheet
    Dim i As Integer
      'отключаем обновление экрана, чтобы не мелькало и для быстродействия
    Application.ScreenUpdating = False
       
    Set CheckList = ThisWorkbook.Worksheets("Array")
      
    FilesCount = 1
      'Поиск всех текстовых файлов в папке
    TxtFileName = Dir(ThisWorkbook.Path & "\" & "*.txt")
      
      'цикл по всем текстовым файлам в папке
    Do Until TxtFileName = ""
        LastRow = CheckList.Cells(Rows.Count, 1).End(xlUp).Row
          'просматриваем CheckList, есть ли там FileName
        Set IsFileAdded = CheckList.Range("A1:A" & LastRow).Find(TxtFileName)
          'Если отсутствует, то...
        If IsFileAdded Is Nothing Then
              'добавляем FileName в CheckList
            CheckList.Range("A" & LastRow + 1).Value = TxtFileName
              'Увеличиваем массив до номера последнего найденного файла,
              ' с сохранением предыдущих элементов
            ReDim Preserve TxtFiles(1 To FilesCount)
              'добавляем FileName в массив TxtFiles
            TxtFiles(FilesCount) = TxtFileName
              'Повторить поиcк с теми же аргументами
            TxtFileName = Dir
            FilesCount = FilesCount + 1
              ''Если найдено...
        Else
            FilesCount = FilesCount
            TxtFileName = Dir
        End If
    Loop
      ''Если N = 1, значит новых файлов не найдено, добавлять нечего
    If FilesCount = 1 Then MsgBox "Новых выписок не найдено": Exit Sub:
      
      'создаем schema.ini на основе полученного массива с именами файлов
    CreateSchemaIni (TxtFiles())
      
      'снимает защиту с листа
    ActiveSheet.Unprotect
      
      'цикл по всем элементам полученного массивами
    For i = 1 To FilesCount - 1
          'статусбар для отслеживания прогресса
        Application.StatusBar = "Выполнено: " & Int(100 * i / (FilesCount - 1)) & "%"
          'чтобы форма перерисовывалась
        DoEvents
          'вызываем процедуру получения данных из текстового файла
        GetDataFromTxtFile (TxtFiles(i))
    Next i
              
      'автоподбр ширины столбцов (пока что закомментировал, если надо вкл., то нужно раскомментировать)
    'Range("A2").CurrentRegion.EntireColumn.AutoFit
      'ставим автофильтр
    Range("A1:H" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter
    
      'ставим защиту на лист с возможностью выделения ячеек и использования автофильтра
    ActiveSheet.Protect AllowFiltering:=True
      'удаляем schema.ini
    DeleteSchemaIni
      'очищаем статусбар
    Application.StatusBar = False
      'включаем обновление экрана
    Application.ScreenUpdating = True
    
    MsgBox "Обновлено"
End Sub

Sub CreateSchemaIni(TxtFiles As Variant)

    Dim i As Integer
      'открываем/создаем schema.ini
    Open ThisWorkbook.Path & "\" & "schema.ini" For Output As #1
    
      'для каждого файла в массиве с текстовыми фалами...
    For i = LBound(TxtFiles) To UBound(TxtFiles)
        'если имя фала содержит BIP, то кодировка будет 65001
      If InStr(TxtFiles(i), "BIP") > 0 Then
        Print #1, "[ " & TxtFiles(i) & "]" & vbNewLine & "ColNameHeader=False" & vbNewLine & _
        "Format = TabDelimited" & vbNewLine & "TextDelimiter=None" & vbNewLine & "CharacterSet = 65001" & vbNewLine
        'если не содержит BIP, то кодировка 1251
      Else
        Print #1, "[ " & TxtFiles(i) & "]" & vbNewLine & "ColNameHeader=False" & vbNewLine & _
        "Format = TabDelimited" & vbNewLine & "TextDelimiter=None" & vbNewLine & "CharacterSet = 1251" & vbNewLine
      End If
    Next i
    
    Close #1

End Sub

Sub DeleteSchemaIni()

    Kill ThisWorkbook.Path & "\" & "schema.ini"
    
End Sub

Sub GetDataFromTxtFile(TxtFile As String)
      'TxtConn - соединение с БД (в данном случае БД - текстовый файл)
      'TxtRs - набор записей Recordset
    Dim TxtConn As ADODB.Connection
    Dim TxtRs As ADODB.Recordset
      'DBPath - путь к БД
      'ConnStr - строка подключения к БД
      'LastRow - определение последней строки
    Dim DBPath As String
    Dim ConnStr As String
    Dim LastRow As Long
            
    DBPath = ThisWorkbook.Path
    ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBPath & ";Extended Properties='text;HDR=No;FMT=Delimited';"
 
    Set TxtConn = New ADODB.Connection
    Set TxtRs = New ADODB.Recordset
    
    TxtConn.ConnectionString = ConnStr
                               
    TxtConn.Open
      'закрыть соединение в случае ошибки
    On Error GoTo CloseConnection
                                        
    With TxtRs
        .ActiveConnection = TxtConn
          'SQL-запрос к БД
        .Source = "SELECT * FROM " & "[" & TxtFile & "] " & ""
        .LockType = adLockReadOnly
        .CursorType = adOpenForwardOnly
        .Open
    End With
      'закрыть Recordset в случае ошибки
    On Error GoTo CloseRecordset
      'последняя заполненная строка по столбцу "А"
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
      'вставляем Recordset ниже последней заполненной строки
    Range("A" & LastRow + 1).CopyFromRecordset TxtRs
      'отключаем обработку ошибок
    On Error GoTo 0
    
CloseRecordset:
    TxtRs.Close
CloseConnection:
    TxtConn.Close
       
End Sub