Функция Array2worksheet позволяет быстро сформировать лист на основании данных из двумерного массива

Sub Array2worksheet(ByRef sh As Worksheet, ByVal Arr, ByVal ColumnsNames)

' Получает двумерный массив Arr с данными,

' и массив заголовков столбцов ColumnsNames.

' Заносит данные из массива на лист sh

If UBound(Arr, 1) > sh.Rows.Count - 1 Or UBound(Arr, 2) > sh.Columns.Count Then

MsgBox "Массив не влезет на лист " & sh.Name, vbCritical, _

"Размеры массива: " & UBound(Arr, 1) & "*" & UBound(Arr, 2): End

End If

With sh

.UsedRange.Clear

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

.Range("a1").Resize(, ColumnsNamesCount).Value = ColumnsNames

.Range("a1").Resize(, ColumnsNamesCount).Interior.ColorIndex = 15

.Range("a2").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr

.UsedRange.EntireColumn.AutoFit

End With

End Sub

Sub ПримерИспользованияФункции_Array2worksheet()

' формируем двумерный массив, и заполняем его данными

ReDim MyArr(1 To 20, 1 To 3)

For i = 1 To 20: For j = 1 To 3: MyArr(i, j) = "Ячейка " & i & " * " & j: Next j: Next i

' создаём новую книгу, а в ней - лист для массива

Dim sh As Worksheet: Set sh = Workbooks.Add(-4167).Worksheets(1): sh.Name = "Массив"

' заносим данные из массива MyArr на лист sh

Array2worksheet sh, MyArr, Array("Столбец 1", "Столбец 2", "Столбец 3")

End Sub

Несколько модернизированный вариант функции - вставку на лист можно начинать с любой выбранной ячейки:

Sub Array2worksheetEx(ByRef FirstCell As Range, ByVal Arr, ByVal ColumnsNames)

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

' Заносит данные из массива на лист, начиная с ячейки FirstCell

Dim sh As Worksheet: Set sh = FirstCell.Worksheet

If UBound(Arr, 1) > sh.Rows.Count - FirstCell.Row Or _

UBound(Arr, 2) > sh.Columns.Count - FirstCell.Column Then

MsgBox "Массив не влезет на лист " & sh.Name, vbCritical, _

"Размеры массива: " & UBound(Arr, 1) & "*" & UBound(Arr, 2): End

End If

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

On Error Resume Next

With FirstCell.Resize(1, ColumnsNamesCount)

.ClearContents

Intersect(sh.Range((FirstCell.Row + 1) & ":" & sh.Rows.Count), _

sh.UsedRange, .EntireColumn).ClearContents

.Value = ColumnsNames

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

FirstCell.Offset(1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr

.EntireColumn.AutoFit

End With

End Sub

• 29844 просмотра