Вставить массив в определенные строки и столбцы в таблице - PullRequest
Новая
       13

Вставить массив в определенные строки и столбцы в таблице

0 голосов
/ 08 мая 2019

Я написал функцию для записи содержимого двумерного массива в существующую таблицу. Ничто не будет удалено со стола. Новые строки должны быть добавлены внизу. Количество столбцов зависит от размера второго измерения массива, и я предполагаю, что в таблице достаточно столбцов.

Моя проблема: как я могу сослаться на диапазон в таблице без: а) наличие листа с таблицей в качестве активного листа и б) без необходимости ссылаться на рабочий лист (как сейчас присутствует в коде; см. ниже)?

См. Приведенный ниже код, который я пробовал. 

Function PasteArrayToTable(tblDestinationTable As ListObject, arrSourceArray() As Variant)

'Note: works for arrays starting with index = 1 (option base 1)!

Dim lngNewRows As Long
Dim lngHeaderRowPosition As Long
Dim intHeaderColumnPosition As Long
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim intFirstColumn As Integer
Dim intLastColumn As Integer
Dim lngNrOfRecordsAtStart As Long

'Number of rows to be added
lngNewRows = UBound(arrSourceArray, 1)

'If the array contains rows, then write them to the destination table
If lngNewRows > 1 Then

    'Get header position of destination table
    lngHeaderRowPosition = tblDestinationTable.HeaderRowRange.Row
    intHeaderColumnPosition = tblDestinationTable.HeaderRowRange.Column

    'Get number of records in table before pasting array, in order to remove afterwards an empty row if the table has 0 rows
    lngNrOfRecordsAtStart = tblDestinationTable.ListRows.Count

    'Add rows to table
    tblDestinationTable.Resize tblDestinationTable.Range.Resize(tblDestinationTable.Range.Rows.Count + lngNewRows)

    'Determine positions where to write array to
    lngFirstRow = lngHeaderRowPosition + tblDestinationTable.ListRows.Count + 1 - lngNewRows
    lngLastRow = lngHeaderRowPosition + tblDestinationTable.ListRows.Count
    intFirstColumn = intHeaderColumnPosition
    intLastColumn = intFirstColumn - 1 + UBound(arrSourceArray, 2)

    'Write array to determined positions. Note: there's no check whether the table has the required number of columns, nor
    'whether the number of lines fit on the page
    Dim wks As Worksheet
    Set wks = Worksheets("Blad1")
    With wks
        .Range(.Cells(lngFirstRow, intFirstColumn), .Cells(lngLastRow, intLastColumn)).Value = arrSourceArray
    End With

    'Remove empty row if present
    If lngNrOfRecordsAtStart = 0 Then
        tblDestinationTable.ListRows(1).Delete
    End If

End If

End Function

Так, как сделать ссылку на «ячейки» в таблице?

1 Ответ

0 голосов
/ 08 мая 2019

Ниже кода, который решает проблему. 

Function PasteArrayToTable(tblDestinationTable As ListObject, arrSourceArray() As Variant)

'Note: works for arrays starting with index = 1 (option base 1)!

Dim lngHeaderRowPosition As Long
Dim intHeaderColumnPosition As Long
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim intFirstColumn As Integer
Dim intLastColumn As Integer

'If the array contains rows, then write them to the destination table
If UBound(arrSourceArray, 1) > 1 Then

    'Get header position of destination table
    lngHeaderRowPosition = tblDestinationTable.HeaderRowRange.Row
    intHeaderColumnPosition = tblDestinationTable.HeaderRowRange.Column

    'Determine positions where to write array to
    lngFirstRow = lngHeaderRowPosition + tblDestinationTable.ListRows.Count + 1
    lngLastRow = lngFirstRow + UBound(arrSourceArray, 1) - 1
    intFirstColumn = intHeaderColumnPosition
    intLastColumn = intFirstColumn + UBound(arrSourceArray, 2) - 1

    'Write array contents to the bottom of the destination table
    With tblDestinationTable.Parent
        .Range(.Cells(lngFirstRow, intFirstColumn), .Cells(lngLastRow, intLastColumn)).Value = arrSourceArray
    End With

End If

End Function
...