1с Ведомость оборотная Excel Макрос VBA

2. Подгрузка в Оборотную ведомость категорий и сроков годности Из файла подгружаем значение срока годности для каждого товара и категории 5 уровней.

3. Простановка сроков годности для каждой Приходной накладной Для каждой приходной накладной устанавливается срок годности ДО по формуле: Дата накладной + Срок годности товара.

4. Формирование строки с остатком по срокам годности Обычно в учетной системе (1С и других) можно посмотреть товародвижение по каждому товару. Приход на склад (Приходная накладная) и расход (в данном случае Z-отчёт). В столбце конечный остаток можно посмотреть сколько единиц товара осталось на складе (Столбец конечный остаток) после каждой операции. Идея состоит в том, чтобы мы видели не просто общий остаток по каждому товару, но и условный срок годности по каждой единице товара. В новом столбце Остаток по срокам, который мы делаем отображается: 2 до 10.08, 5 до 15.08 Это значит 2 батона колбасы сроком до 10 августа 2018 и 5 батонов сроком до 15 августа 2018 г. Товары расходуются по методу FIFO (сначала продаются самые старые из всех что есть и тд). Z-отчёт — это продажи.

' FIFO ФИФО оборотная ведомость
 
Option Explicit
 
Private bDebug As Boolean
Private AppCalc As Variant, AppScr As Boolean, AppDispAl As Boolean    'для Excel-Speed
 
Public Function arr_2d_Copy_2_New(arr_2d(), _
                                  Optional ByVal Row_Start As Long, _
                                  Optional ByVal Row_End As Long, _
                                  Optional ByVal Col_Start As Long, _
                                  Optional ByVal Col_End As Long) As Variant
'https://drakonhub.com/ide/doc/pme/93
 
    arr_2d_Copy_2_New = arr_2d_Copy(arr_2d, _
                                    Row_Start, Row_End, Col_Start, Col_End)
End Function
 
Private Sub arr_2d_Copy_test()
 
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim arr_2d_Sour() As Variant, arr_2d_Dest() As Variant
    With ws
        ' плацдарм очистить
        .Columns("K:S").ClearContents
 
        arr_2d_Sour = .Cells(1, 1).CurrentRegion.Value
 
        Dim Row_Start As Long, Row_End As Long, _
            Col_Start As Long, Col_End As Long
        ' массив границы генерирую
        Row_End = Случ_Между(LBound(arr_2d_Sour), _
                             UBound(arr_2d_Sour))
        Row_Start = Случ_Между(LBound(arr_2d_Sour), Row_End)
 
        Col_End = Случ_Между(LBound(arr_2d_Sour, 2), _
                             UBound(arr_2d_Sour, 2))
        Col_Start = Случ_Между(LBound(arr_2d_Sour, 2), Col_End)
        ' массив создаю копированием
        arr_2d_Dest = arr_2d_Copy(arr_2d_Sour, Row_Start, Row_End, _
                                  Col_Start, Col_End)
 
        Массив_Вставить arr_2d_Dest, .Cells(1, 11)
    End With    'ws
End Sub
 
Public Function arr_2d_Copy(arr_2d_Sour() As Variant, _
                            Optional ByVal Row_Start As Long, Optional ByVal Row_End As Long, _
                            Optional ByVal Col_Start As Long, Optional ByVal Col_End As Long) _
                            As Variant
' Часть массива скопировать в новымй массив, _
  а если не заданы аргументы, то один в один
 
'Подставляю значения границ, если они пустые
    If Row_Start = 0 Then Row_Start = LBound(arr_2d_Sour)
    If Row_End = 0 Then Row_End = UBound(arr_2d_Sour)
    If Col_Start = 0 Then Col_Start = LBound(arr_2d_Sour, 2)
    If Col_End = 0 Then Col_End = UBound(arr_2d_Sour, 2)
 
 
    ' Делаю границы нового массива
    Dim Row_End_Dest As Long, Col_End_Dest As Long
    Row_End_Dest = Row_End - Row_Start + 1
    Col_End_Dest = Col_End - Col_Start + 1
 
    ' Массив создаю
    Dim arr_2d_Dest() As Variant
    ReDim arr_2d_Dest(LBound(arr_2d_Sour) To Row_End_Dest, _
                      LBound(arr_2d_Sour, 2) To Col_End_Dest)
 
    Dim y As Long, x As Long
 
    On Error Resume Next    ' для ошибок в "ячейках"
 
    For y = LBound(arr_2d_Dest) To UBound(arr_2d_Dest)
        For x = LBound(arr_2d_Dest, 2) To UBound(arr_2d_Dest, 2)
 
            arr_2d_Dest(y, x) = arr_2d_Sour(Row_Start + y - 1, Col_Start + x - 1)
 
        Next
        If Row_Start + y > Row_End And _
           Col_Start + y > Col_End Then _
           Exit For
    Next
 
    If IsArray(arr_2d_Dest) Then _
       arr_2d_Copy = arr_2d_Dest
 
End Function
 
Public Function arr_2d_Границы_Проверка(arr_2d() As Variant, _
                                        ByVal Row_Start As Long, _
                                        ByVal Row_End As Long, _
                                        Optional ByVal Col_Start As Long, _
                                        Optional ByVal Col_End As Long) As Boolean
 
    arr_2d_Границы_Проверка = True
 
    If Row_End < LBound(arr_2d) And _
       Row_End > UBound(arr_2d) Then _
       arr_2d_Границы_Проверка = False
 
    If Row_Start < LBound(arr_2d) And _
       Row_Start > UBound(arr_2d) Then _
       arr_2d_Границы_Проверка = False
 
    If Row_Start > Row_End Then Row_Start = Row_End
 
    If Col_End < LBound(arr_2d) And _
       Col_End > UBound(arr_2d) Then _
       arr_2d_Границы_Проверка = False
 
    If Col_Start < LBound(arr_2d) And _
       Col_Start > UBound(arr_2d) Then _
       arr_2d_Границы_Проверка = False
 
    If Col_Start > Col_End Then Col_Start = Col_End
 
    ' потом дописать для столбцов
End Function
 
Public Sub Excel_Speed_off(Optional ByVal DeMand As Boolean = False)    ' ускорение убрать
' Если Demand = True, то  принудительно вернуть
 
'Тест
'     Excel_Speed_off 1
    With Application
        If DeMand Then
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
            .DisplayAlerts = True
        Else
            If IsEmpty(AppCalc) = False Then
                .Calculation = AppCalc
                .ScreenUpdating = AppScr
                .DisplayAlerts = AppDispAl
            End If
        End If
 
        .CutCopyMode = False
        .StatusBar = vbNullString
    End With
End Sub
 
Public Sub Excel_Speed_ON()                        'ускорить excel
'В начало модуля:
' Public AppCalc As Variant, AppScr As Boolean, AppDispAl As Boolean 'для Excel-Speed
    With Application
        If IsEmpty(AppCalc) Then
            AppCalc = .Calculation
            AppScr = .ScreenUpdating
            AppDispAl = .DisplayAlerts
        End If
        If .Calculation <> xlCalculationManual Then _
           .Calculation = xlCalculationManual
        If .ScreenUpdating <> False Then _
           .ScreenUpdating = False
        If .DisplayAlerts <> False Then _
           .DisplayAlerts = False
    End With
End Sub
 
Public Function extract_Between(ByVal txt As Variant, _
                                ByVal sLeft As String, _
                                ByVal sRight As String) As String
'извлечь между
    If Len(txt) > 0 And Len(txt) > 0 And Len(txt) > 0 And _
       InStr(txt, sLeft) > 0 And InStr(txt, sRight) > 0 Then
        Dim s
        s = Split(txt, sLeft)
        s = Split(s(1), sRight)
        extract_Between = s(0)
    Else
        'обработка ошибки
        ' Err.Raise 567, "extract_Between", "Ошибка"
    End If
End Function
 
Public Sub MsgBox4Debug(Optional ByVal sPrompt As String = vbNullString, _
                        Optional ByVal sTitle As String = vbNullString)
    Select Case MsgBox(sPrompt _
                       & vbCrLf & "Да = Продолжить" _
                       & vbCrLf & "Нет = Отладка" _
                       & vbCrLf & "Отмена = Выход из макроса" _
                       , vbYesNoCancel Or vbCritical Or vbDefaultButton1, _
                       sTitle)
    Case vbYes
        'ничего
    Case vbNo
        Debug.Print sPrompt, sTitle
        Stop
    Case vbCancel
        End                          '===>>>
    End Select
End Sub
 
 
Public Sub ProgressBar_Turbo(ByRef txt As String, _
                             ByRef i As Long, _
                             ByRef max As Long)
' dim Турбо as long 'в начало модуля
    Dim Турбо As Long
    Турбо = Len(CStr(max)) * Len(CStr(max))
 
    If bDebug Then
        Application.StatusBar = Right$(txt, 123) & " прогресс: " & Format$(i, "# ### ###") & _
                                " из " & Format$(max, "# ### ###") & ": " & _
                                Format$(i / max, "Percent")
 
    Else
 
        If Турбо = Int((Турбо * Rnd) + 1) Then
            Application.StatusBar = txt & " прогресс: " & Format$(i, "# ### ###") & _
                                    " из " & Format$(max, "# ### ###") & ": " & _
                                    Format$(i / max, "Percent")
            With Application
 
                If Second(Time) > 5 Then
 
                    If .ScreenUpdating = False Then .ScreenUpdating = True
                    DoEvents
                Else
 
                    If .ScreenUpdating = True Then .ScreenUpdating = False
                End If
            End With
        End If
    End If
End Sub
 
Public Function ИмяФайлаБезПути(ByRef s As String) As String
    ИмяФайлаБезПути = Right$(s, Len(s) - InStrRev(s, "\"))
End Function
 
Public Sub Массив_Вставить(arr_Xd(), rng As Range)
' массив вставить на лист  1 или 2 размерные
 
    If IsArray(arr_Xd) = False Then MsgBox4Debug    ''IsArray(arr_Xd) = False ","Массив_Вставить"
    If rng Is Nothing Then MsgBox4Debug    ''rng Is Nothing ","Массив_Вставить"
 
    Dim Option_Base_Offset
    Option_Base_Offset = IIf(Option_Base = 0, 1, 0)
 
    With rng
 
        Select Case Массив_Размерность(arr_Xd)
        Case 1
            .Resize(UBound(arr_Xd) + Option_Base_Offset, 1) = _
            Application.WorksheetFunction.Transpose(arr_Xd)
        Case 2
            .Resize(UBound(arr_Xd), _
                    UBound(arr_Xd, 2)) = arr_Xd
        Case Else
            Err.Raise 567, "Массив_Вставить", "Массив размерность не 1 и на 2"
        End Select
    End With
End Sub
 
Public Function Массив_2d_Найти_в_Столбце(arr_2d, ByVal iCol As Long, _
                                          ByVal vVar As Variant, ByVal Целиком_1_Часть_2 As Long, _
                                          Optional ByVal Вхождение_Номер As Long = 1) _
                                          As Long
    Dim y As Long
 
    If Целиком_1_Часть_2 = 1 Then
 
        For y = LBound(arr_2d) To UBound(arr_2d)
 
            'If InStr(arr_2d(y, iCol), "102314") Then Stop
 
 
            If CStr(arr_2d(y, iCol)) = vVar Then _
               Exit For
        Next
    Else
 
        For y = LBound(arr_2d) To UBound(arr_2d)
 
            If InStr(arr_2d(y, iCol), vVar) > 0 Then _
               Exit For
        Next
    End If
 
    Массив_2d_Найти_в_Столбце = y
 
    'счётчик вышел за предел цикла = не найдено
    If y > UBound(arr_2d) Then _
       Массив_2d_Найти_в_Столбце = 0
 
End Function
 
Public Sub Массив_2d_Найти_в_Столбце_test()
    Dim rng As Range, arr_2d() As Variant
    Dim vStr As Variant, vVar As Variant, vLong As Long
 
    Set rng = Application.Intersect(ActiveSheet.Columns(1), _
                                    ActiveSheet.UsedRange)
 
    arr_2d = rng.Value
 
    With ActiveCell
        vLong = CVar(.Value)
        vStr = CVar(.Value)
        vVar = CVar(.Value)
    End With
 
    Debug.Print Массив_2d_Найти_в_Столбце(arr_2d(), 1, CVar(vLong), 1)
    Debug.Print Массив_2d_Найти_в_Столбце(arr_2d(), 1, CVar(vStr), 1)
    Debug.Print Массив_2d_Найти_в_Столбце(arr_2d(), 1, vVar, 1)
 
End Sub
 
Public Function Массив_Размерность(arr()) As Long   'возвращает количество измерений массива Arr
    Dim i As Long, x As Long
    On Error GoTo eXX
    ' увеличиваю i пока не получим ошибку _
      попытки получить UBound по данному измерению
    Do: i = i + 1
        x = UBound(arr, i)
    Loop
eXX:
    Массив_Размерность = i - 1
End Function
 
'простой и сортировка по любому количеству столбцов в любом порядке.
' Кому надо направление сортировки и произвольные границы,
'можете доработать сами.
' Последняя строка массива передается, потому что массив
'может быть заполнен не весь
'Вызов: SortArray ar, 5, 2, 0, 1
'Ar - массив, 5 - последняя строка, 2, 0, 1 - столбцы для сортировки
Private Sub Массив_Сортировка(myArray, countRows, ParamArray sortC())
    Dim cRA%, cR%, minR%, cS%, cE%, countC%, tempV
 
    countRows = UBound(myArray)
 
    For cRA = 0 To countRows - 1
        minR = cRA
 
        For cR = cRA + 1 To countRows - 1
 
            For cS = 0 To UBound(sortC)
 
                If myArray(cR, sortC(cS)) <> myArray(minR, sortC(cS)) Then
 
                    If myArray(cR, sortC(cS)) < myArray(minR, sortC(cS)) Then _
                       minR = cR
                    Exit For
                End If
            Next
        Next
 
        If minR > cRA Then
            Dim cC As Long
            'меняем местами строки
            For cC = 0 To UBound(myArray, 2)
 
                tempV = myArray(cRA, cC)
 
                myArray(cRA, cC) = myArray(minR, cC)
 
                myArray(minR, cC) = tempV
            Next
        End If
    Next
End Sub
 
Private Sub Массив_Сортировка_test()
    Dim arr()
    arr = Selection
    Массив_Сортировка arr, 1
End Sub
 
Public Function _
       Массив_Столбец_Ячейка_не_Пустая_Одиночная _
       (arr_Xd(), _
        ByVal iCol As Long, ByVal iRow As Long) _
        As Long
 
    If IsArray(arr_Xd) = False Then _
       MsgBox4Debug "IsArray(arr_Xd) = False", "Массив_Столбец_Ячейка_не_Пустая_Одиночная"
 
    If iRow < LBound(arr_Xd) Or iRow > UBound(arr_Xd) Then _
       MsgBox4Debug " iRow < LBound(arr_Xd) Or iRow > UBound(arr_Xd) ", "Массив_Столбец_Ячейка_не_Пустая_Одиночная"
 
    Dim y As Long
 
    Select Case Массив_Размерность(arr_Xd)
    Case 1
        For y = iRow To UBound(arr_Xd)
 
            If y < UBound(arr_Xd) Then
 
                If arr_Xd(y) <> vbNullString And _
                   arr_Xd(y + 1) = vbNullString Then
 
                    Массив_Столбец_Ячейка_не_Пустая_Одиночная = y
                End If
            End If
        Next
 
    Case 2
 
        If iCol < LBound(arr_Xd, 2) Or iCol > UBound(arr_Xd, 2) Then _
           MsgBox4Debug " iCol < LBound(arr_Xd, 2) Or iCol > UBound(arr_Xd, 2)", "Массив_Столбец_Ячейка_не_Пустая_Одиночная"
 
        For y = iRow To UBound(arr_Xd)
 
            If y < UBound(arr_Xd) Then
 
                If arr_Xd(y, iCol) <> vbNullString And _
                   arr_Xd(y + 1, iCol) = vbNullString Then
 
                    Массив_Столбец_Ячейка_не_Пустая_Одиночная = y
                    Exit For
                End If
            End If
        Next
 
    Case Else
        MsgBox4Debug "Массив_Столбец_Ячейка_не_Пустая_Одиночная"
    End Select
 
    If y >= UBound(arr_Xd) Then _
       Массив_Столбец_Ячейка_не_Пустая_Одиночная = UBound(arr_Xd)    'не найдено, поэтому последняя
End Function
 
Public Function ОткрытаЛиКнига(ByVal wbName As String) As Boolean
' вызов If Not ОткрытаЛиКнига(ИмяФайла) Then Workbooks.Open ИмяФайла
    wbName = Right$(wbName, Len(wbName) - InStrRev(wbName, "\"))    ' отсечь путь
    Dim wbBook As Workbook
    For Each wbBook In Workbooks
        If wbBook.Name = wbName Then
            ОткрытаЛиКнига = True
            Exit For
        End If
    Next wbBook
End Function
 
Public Function Столбец_Крайний(ws As Worksheet) As Long
' Найти последний столбец с данными, непустой
    On Error Resume Next
    Столбец_Крайний = _
    ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
                  SearchDirection:=xlPrevious).Column
    If Столбец_Крайний = 0 Then Столбец_Крайний = 1
End Function
 
Public Function Строка_Крайняя(ws As Worksheet) As Long
' Найти последняя строку  с данными, непустую
    On Error Resume Next
    Строка_Крайняя = _
    ws.Cells.Find(What:="*", SearchOrder:=xlByRows, _
                  SearchDirection:=xlPrevious).Row
    If Строка_Крайняя = 0 Then Строка_Крайняя = 1
End Function
 
Public Sub Уровень_Отступа_в_массив(ws As Worksheet, _
                                    Столбец As Long, Строка As Long, arr_2d(), _
                                    arr_Col As Long, arr_Row As Long)
'Для таблиц из 1С
'  заполнить столбец массива уровнями отступа в ячейках столбца листа
 
' ToDo: сделать необходимые проверки
 
    Dim rng As Range, eL As Range
 
    With ws
        Set rng = .Range(.Cells(Строка, Столбец), _
                         .Cells(Строка_Крайняя(ws), Столбец))    '
    End With
 
    Dim y As Long, x As Long
    y = arr_Row: x = arr_Col
 
    For Each eL In rng
        If eL.Value <> vbNullString Then
 
            arr_2d(y, x) = eL.IndentLevel
 
            y = y + 1
 
            ProgressBar_Turbo "Уровень_Отступа_в_массив ", arr_Row, rng.Rows.Count
        End If
    Next
 
    Application.StatusBar = vbNullString
End Sub
 
Public Function Случ_Между(ByVal ОграничНижн As Variant, _
                           ByVal ОграничВерх As Variant, _
                           Optional ByVal StopOnError As Boolean = True) As Long
'Для сокращения кода, чтобы не читать _
  Application.WorksheetFunction.RandBetween(ОграничНижн, _
  ОграничВерх)
'Возвращает случайное целое число, находящееся _
  в диапазоне между двумя заданными числами.
    If IsNumeric(ОграничНижн) = False Or _
       IsNumeric(ОграничВерх) = False Then
 
        If StopOnError Then _
           MsgBox4Debug "Есть НЕ числа", "Случ_Между"
    Else
        ' ничего
    End If
 
    Randomize
 
    Случ_Между = Application.WorksheetFunction. _
                 RandBetween(ОграничНижн, _
                             ОграничВерх)
End Function
 
Public Function Лист_Получить(ByVal Путь As String, _
                              ByVal Файл As String, ByVal Лист As String) _
                              As Worksheet
    Dim wb As Workbook
 
    Путь = Путь & "\" & Файл
 
    If Not ОткрытаЛиКнига(Файл) Then _
       Workbooks.Open Путь
 
    Set wb = Workbooks(Файл)
 
    Set Лист_Получить = wb.Worksheets(Лист)
End Function
 
Public Function Файл_Расширение_без_Имени(str As String) As String
'Возвращает имя файла без расширения
    Dim iPos As Long
    iPos = Len(str) - InStrRev(str, ".")
 
    Файл_Расширение_без_Имени = Right$(str, iPos)
End Function
 
Public Function Файл_Имя_без_Расширения(str As String)
' Возвращает расширение без имени файла
    Dim iPos As Long
    iPos = InStr(str, ".") - 1
 
    Файл_Имя_без_Расширения = Left$(str, iPos)
End Function
 
Public Function Массив_Копировать(arr_Xd(), _
                                  Optional ByVal Row_Start As Long, _
                                  Optional ByVal Row_End As Long, _
                                  Optional ByVal Col_Start As Long, _
                                  Optional ByVal Col_End As Long)
'Накопировать часть массива в массив поменьше
' Баунды нового массива могут начинаться с Row_Start и Col_Start
    Dim Проверка As String
    Проверка = Массив_Копировать_Проверка(arr_Xd, Row_Start, Row_End, _
                                          Col_Start, Col_End)
 
    '    If Проверка <> vbNullString Then _
         '       Err.Raise 567, "Проверка", "Массив_Копировать"
 
    If Row_Start = 0 Then Row_Start = LBound(arr_Xd)
    If Row_End = 0 Then Row_End = UBound(arr_Xd)
 
    Dim y As Long, x As Long
 
    Select Case Массив_Размерность(arr_Xd())
    Case 1
        MsgBox4Debug "для 1d пока не сделал", "Массив_Копировать"
    Case 2
 
        Dim arr_2d_New() As Variant
        ReDim arr_2d_New(Row_Start To Row_End, _
                         Col_Start To Col_End)
 
        Dim Row_Offset As Long, Col_Offset As Long
        Col_Offset = 0: Row_Offset = 0
 
        '            Row_Offset = UBound(arr_Xd) - UBound(arr_2d_New)
        '
        '            If UBound(arr_2d_New, 2) > UBound(arr_Xd, 2) Then
        '                Col_Offset = UBound(arr_Xd, 2) - UBound(arr_2d_New, 2)
        '            Else
        '                Col_Offset = 0
        '            End If
 
        On Error Resume Next
 
        For y = Row_Start To Row_End
 
            For x = Col_Start To Col_End
 
                arr_2d_New(y, x) = arr_Xd(y + Row_Offset, x + Col_Offset)
            Next
        Next
    Case Else
        Err.Raise 567, "Массив_Копировать", _
                  "Размерность ещё пока не поддерживается"
    End Select
 
    On Error GoTo 0
 
    If IsArray(arr_2d_New) Then _
       Массив_Копировать = arr_2d_New
 
End Function
 
Public Function Массив_Копировать_Проверка(arr_Xd(), _
                                           Optional ByVal Row_Start As Long, _
                                           Optional ByVal Row_End As Long, _
                                           Optional ByVal Col_Start As Long, _
                                           Optional ByVal Col_End As Long) _
                                           As String
    If IsArray(arr_Xd()) = False Then
        Массив_Копировать_Проверка = "IsArray(arr_Xd()) = False"
    End If
    'Для нулевых значений ничего не делаю
    If Row_Start <> 0 Then
        If Row_Start < LBound(arr_Xd) And Row_Start > UBound(arr_Xd) Then
            Массив_Копировать_Проверка = "Row_Start < LBound(arr_Xd) And Row_Start > UBound(arr_Xd) "
        End If
    End If
 
    If Row_End <> 0 Then
        If Row_End < LBound(arr_Xd) And Row_End > UBound(arr_Xd) Then
            Массив_Копировать_Проверка = "Row_End < LBound(arr_Xd) And Row_End > UBound(arr_Xd) "
            Exit Function
        End If
    End If
 
    If Row_End < Row_Start Then
        Массив_Копировать_Проверка = "Row_End < Row_Start"
    End If
 
    Select Case Массив_Размерность(arr_Xd)
    Case 1
        Массив_Копировать_Проверка = "Для  1d ещё не сделано"
    Case 2
 
        If Col_Start <> 0 Then
            If Col_Start < LBound(arr_Xd, 2) And Col_Start > UBound(arr_Xd, 2) Then
                Массив_Копировать_Проверка = "Col_Start < LBound(arr_Xd,2) And Col_Start > UBound(arr_Xd,2) "
                Exit Function
            End If
        End If
 
        If Col_End <> 0 Then
            If Col_End < LBound(arr_Xd, 2) And Col_End > UBound(arr_Xd, 2) Then
                Массив_Копировать_Проверка = "Col_End < LBound(arr_Xd,2) And Col_End > UBound(arr_Xd,2) "
            End If
        End If
 
        If Col_End < Col_Start Then
            Массив_Копировать_Проверка = "Col_End < Col_Start"
        End If
 
    Case Else
    End Select
 
    If Массив_Копировать_Проверка <> vbNullString Then
        Err.Raise 567, "Массив_Копировать_Проверка", Массив_Копировать_Проверка
    End If
End Function
 
Private Sub Массив_Копировать_test()
 
    Dim arr()
    arr = Selection
    arr = Массив_Копировать(arr, 2, 3, 2, 2)
    Stop
End Sub
 
Public Function f_dic_Uniq_From_arr_2d(arr() As Variant, _
                                       iCol As Long) _
                                       As Dictionary    ' Microsoft Scripying Runtime должен быть включен
' Возвращает словарь из массива
 
    If IsArray(arr) = False Then Exit Function
 
    If iCol < LBound(arr) Or iCol > UBound(arr) Then Exit Function
 
    'позднее связывание
    Dim dic_Temp
    Set dic_Temp = CreateObject("Scripting.Dictionary")
 
    Dim key As Variant, item As Variant
 
    Dim y As Long
    For y = LBound(arr) To UBound(arr)
        key = arr(y, iCol)
        item = key
        If dic_Temp.Exists(key) = False Then _
           dic_Temp.Add key, item
    Next
 
    Set f_dic_Uniq_From_arr_2d = dic_Temp
End Function
 
Private Sub Dic_from_Arr_2d_test()
 
    Dim dic_Temp
    Set dic_Temp = CreateObject("Scripting.Dictionary")
 
    'Дл Матрицы
    dic_Temp = Dic_from_Arr_2d( _
               Диапазон_в_Массив( _
               Range(Cells(1, 1), Cells(47209, 1))), _
               1)
End Sub
 
Public Function Диапазон_в_Массив(rng As Range) As Variant
    Диапазон_в_Массив = rng.Value
End Function
 
Public Function Dic_from_Arr_2d(arr As Variant, _
                                iCol As Long) _
                                As Dictionary    ' Microsoft Scripying Runtime должен быть включен
' Возвращает словарь из массива
 
'позднее связывание
    Dim dic_Temp
    Set dic_Temp = CreateObject("Scripting.Dictionary")
 
 
    Dim y As Long
 
    For y = LBound(arr) To UBound(arr)
        dic_Temp.Add y, arr(y, iCol)
    Next
 
    Set Dic_from_Arr_2d = dic_Temp
End Function
 
 
Sub ShowUniqKeys()
    Dim Element
    Dim dic_Temp As New Dictionary
    With dic_Temp
        For Each Element In Array("Один", "Один", "Один", "Один", "Один")
            ' Используем Count в качестве значения ключа
            ' таким образом ключи будут 0,1,2,3,4
            .item(.Count) = Element
        Next
        MsgBox Join(.Keys, vbLf)
    End With
End Sub
 
Public Function App_Union(rng_Union As Range, _
                          ByVal rng As Range) _
                          As Range    ' InExSu
' Range Union, объединение диапазонов
' Для упрощения чтения кода
' вызов: Set rng_union = App_Union(rng_union, .Rows(x))
 
'    If rng_union.Parent.Name <> rng.Parent.Name Then MsgBox4Debug
 
    If Not rng_Union Is Nothing Then
        ' If rng_Union.Parent.Name <> rng.Parent.Name Then MsgBox4Debug
        Set rng_Union = Application.Union(rng_Union, rng)
    Else
        Set rng_Union = rng
    End If
 
    Set App_Union = rng_Union
End Function
 
 
Public Function массив_из_Столбцов(ByVal ws As Worksheet, _
                                   ByVal Row_Start As Long, ByVal Row_End As Long, _
                                   arr_1d_CoL() As Variant) As Variant
 
    Dim ws_Temp As Worksheet
    ws_Ведомость.Copy After:=ActiveSheet
    Set ws_Temp = ActiveSheet
 
    Dim rng_Union As Range, rng As Range, x As Long
 
    With ws_Temp
 
        .Cells.UnMerge    'копирование боится объединённых ячеек
 
        For x = LBound(arr_1d_CoL) To UBound(arr_1d_CoL)
 
 
            Set rng = .Range(.Cells(Row_Start, arr_1d_CoL(x)), .Cells(Row_End, arr_1d_CoL(x)))
 
 
            Set rng_Union = App_Union(rng_Union, rng)
 
        Next
    End With
 
    массив_из_Столбцов = Диапазон_на_лист_и_в_массив(rng_Union)
 
    Лист_Удалить_Без_Вопросов ws_Temp
End Function
 
Public Sub Лист_Удалить_Без_Вопросов(ws As Worksheet)
    Dim ApPl_Event As Boolean, Appl_Alert As Boolean, ws_Act As Worksheet
 
    With Application
 
        ApPl_Event = .EnableEvents
        Appl_Alert = .DisplayAlerts
 
        .EnableEvents = False
        .DisplayAlerts = False
 
        ws.Delete
 
        .EnableEvents = ApPl_Event
        .DisplayAlerts = Appl_Alert
    End With
End Sub
Public Function Диапазон_на_лист_и_в_массив(ByVal rng As Range) As Variant
' несвязные, несмежные диапазоны коппруются в массив не полнотсью,
' а здесь полнсотью
 
    If rng Is Nothing Then _
       Err.Raise 567, "Диапазон_на_лист_и_в_массив", "rng Is Nothing"
 
    Dim wb As Workbook, Row_End As Long
    Set wb = Workbooks.Add
 
    With wb.ActiveSheet
        rng.Copy .Cells(1, 1)
 
        Диапазон_на_лист_и_в_массив = .UsedRange.Value
    End With
 
    wb.Close False
End Function