Функция предназначена для сохранения двумерного массива в файл формата XLS

Sub SaveArray(ByVal Arr, ByVal ColumnNames, ByVal DocName$)

    ' Получает двумерный массив Arr с данными, и массив заголовков столбцов ColumnNames.

    ' Создаёт новый файл в подпапке СФОРМИРОВАННЫЕ ДОКУМЕНТЫ с именем DocName$

    On Error Resume Next

    ' создаём подпапку (там же, где текущий файл Excel)

    folder$ = ThisWorkbook.Path & "\СФОРМИРОВАННЫЕ ДОКУМЕНТЫ\": MkDir folder$

    Application.ScreenUpdating = False

    Dim sh As Worksheet, wb As Workbook

    Set wb = Application.Workbooks.Add(xlWBATWorksheet)        ' создаём новый файл Excel

    Set sh = wb.Worksheets(1): sh.Name = DocName$

    ColumnsNamesCount = UBound(ColumnNames) - LBound(ColumnNames) + 1

    With sh.Range("a1").Resize(, ColumnsNamesCount)        ' выводим заголовки столбцов

        .Value = ColumnNames

        .Interior.ColorIndex = 15: .Font.Bold = True

        With sh.Range("a2").Resize(UBound(Arr, 1), UBound(Arr, 2))        ' и данные

            .Value = Arr

            .Borders.LineStyle = xlContinuous

        End With

        .EntireColumn.AutoFit

    End With

    ' сохраняем и закрываем созданный файл Excel

    Filename$ = folder$ & DocName$ & " " & Format(Now, "dd-mm-yyyy hh-nn-ss") & ".xls"

    wb.SaveAs Filename$, xlWorkbookNormal        ' формат XLS

    wb.Close False

    ' показываем созданный файл в папке

    CreateObject("WScript.Shell").Run "explorer.exe /e,/select,""" & Filename$ & """"

    Application.ScreenUpdating = True

End Sub

Пример использования:

Sub test_SaveArray()

    Arr = Range("a2:f20").Value

    Headers = Array("Штрихкод", "Наименование", "Кол-во", "Артикул", "Цена", "Поставщик")

    SaveArray Arr, Headers, "Склад" ' создаём из массива Arr файл Excel с именем СКЛАД

End Sub

• 3010 просмотров