Vba helper

Function IsBookOpen(wbName As String) As Boolean
    Dim wbBook As Workbook
    For Each wbBook In Workbooks
        If wbBook.Name <> ThisWorkbook.Name Then
            If Windows(wbBook.Name).Visible Then
                If wbBook.Name = wbName Then IsBookOpen = True: Exit For
            End If
        End If
    Next wbBook
End Function

'Функция сцепления диапазона ячеек, при желании, с разделителем.
Public Function ъСцепитьДиапазон(ByRef our_range As Range, Optional ByVal our_separator As String = "") As String
Dim cell As Range
Dim merge As String
For Each cell In our_range
    If cell.Text <> "" Then
        merge = merge & our_separator & cell.Text
    End If
Next
merge = Mid(merge, Len(our_separator) + 1)
ъСцепитьДиапазон = merge
End Function

'Проверка существования листа
Function isSheet_Ecist(ByVal listname As String) As Boolean
Dim WS As Object
For Each WS In Excel.Worksheets
    If WS.Name = listname Then
    isSheet_Exist = True: Exit Function
    End If
Next
isSheet_Exist = False
End Function

Public Function Unique_String(ByVal rng As Range) As String()
'получаем массив уникальных значений
    Dim l_arr As Long, n As Long, i As Long
     Dim avArr() As String
     arr_of_range = rng
     l_arr = UBound(arr_of_range)
     With New Collection
         On Error Resume Next
         For n = 1 To l_arr
         .Add arr_of_range(n, 1), arr_of_range(n, 1) 'Cstr() - если числа попадаются
            If Err = 0 Then
                 i = i + 1
                 ReDim Preserve avArr(1 To i)
                 avArr(i) = arr_of_range(n, 1)
             Else: Err.Clear
             End If
         Next
     End With
     Unique_String = avArr
 End Function

Function getNamebyMonthNum(ByVal Mnum As Byte, Optional Lang As String = "RUS", _
                                            Optional sType As String = "MMMM") As String
'получаем месяц прописью по его номеру
'[$-419] - RUS, [$-409] - ENG, [$-409] - POL
Lang = UCase(Lang)
Select Case Lang
    Case "RUS", "RU": getNamebyMonthNum = Application.Text(DateSerial(1, Mnum, 1), "[$-419]" & sType)
    Case "ENG", "EN": getNamebyMonthNum = Application.Text(DateSerial(1, Mnum, 1), "[$-409]" & sType)
    Case "POL", "PO": getNamebyMonthNum = Application.Text(DateSerial(1, Mnum, 1), "[$-415]" & sType)
End Select
End Function

Public Function MyVLookUp(Search$, Source As Range, Column%, _
                          Optional DownSearch As Boolean = True) As Variant
'ВПР как обычный, но можно поменять поиск на снизу вверх,
'просто добавить через запятую 0 (или False)
     Dim iCell As Range
     If DownSearch = True Then
       Set iCell = Source.Columns(1).Find(Left(Search, 255), _
       Source(Source.Rows.Count, 1), xlValues, xlWhole, , xlNext)
     Else
       Set iCell = Source.Columns(1).Find(Left(Search, 255), _
       Source(1, 1), xlValues, xlWhole, , xlPrevious)
    End If

    If Not iCell Is Nothing Then
       MyVLookUp = iCell(1, Column)
    Else
       MyVLookUp = CVErr(xlErrNA)
    End If
End Function

Function Files_in_Folder_Full(ByVal Folder$) As String()
'полный путь файлов в папке
    Dim N%
    Dim fs, f, f1
    Dim Folders() As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Folder)
 
    N = 0
    On Local Error Resume Next
    For Each f1 In f.Files
      N = N + 1
      ReDim Preserve Folders(1 To N) As String
      Folders(N) = Folder & f1.Name '& "\"
   Next f1
   Files_in_Folder_Full = Folders
End Function

Function Files_in_Folder(ByVal Folder$) As String()
'имена файлов в папке
    Dim N%
    Dim fs, f, f1
    Dim Folders() As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Folder)
 
    N = 0
    On Local Error Resume Next
    For Each f1 In f.Files
      N = N + 1
      ReDim Preserve Folders(1 To N) As String
      Folders(N) = f1.Name '& "\"
   Next f1
   Files_in_Folder = Folders
End Function

Function Subfolders_in_Full(ByVal Folder$) As String()
    Dim N%
    Dim fs, f, f1
    Dim Folders() As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Folder)
    Set fc = f.SubFolders
    N = 0
    If Right(Folder, 1) <> Application.PathSeparator Then Folder = Folder & Application.PathSeparator
    On Local Error Resume Next
    For Each f1 In fc
      N = N + 1
      ReDim Preserve Folders(1 To N) As String
      Folders(N) = Folder & f1.Name '& "\"
   Next f1
   Subfolders_in_Full = Folders
End Function
Function Subfolders_in(ByVal Folder$) As String()
    Dim N%
    Dim fs, f, f1
    Dim Folders() As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Folder)
    Set fc = f.SubFolders
 
    N = 0
    On Local Error Resume Next
    For Each f1 In fc
      N = N + 1
      ReDim Preserve Folders(1 To N) As String
      Folders(N) = f1.Name '& "\"
   Next f1
   Subfolders_in = Folders
End Function

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
                       Optional ByVal InitialPath As String = "c:\") As String
    ' функция выводит диалоговое окно выбора папки с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
    Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

Function ФАЙЛРАСШИР(ByVal ПУТЬ As String) As String
    Dim temp As Variant
    If ПУТЬ = "" Then ФАЙЛРАСШИР = "": Exit Function
    temp = Split(ПУТЬ, ".")
    ФАЙЛРАСШИР = temp(UBound(temp))
End Function

Function ФАЙЛИМЯ(ByVal ПУТЬ As String) As String
Dim temp As Variant
If ПУТЬ = "" Then ФАЙЛИМЯ = "": Exit Function
temp = Split(ПУТЬ, Application.PathSeparator)
ФАЙЛИМЯ = temp(UBound(temp))
End Function

Function ФАЙЛБЕЗРАСШИР(ByVal ИМЯ As String) As String
    ФАЙЛБЕЗРАСШИР = Left(ИМЯ, InStrRev(ИМЯ, ".") - 1)
End Function

Sub NumberStyleWithSeparators()
'Числовой формат с пробелами и без сотых
    Selection.NumberFormat = "#,##0"
End Sub