Question

我编写了一个函数，用于将二维数组的内容写入现有表。什么都不会从表中删除。必须在底部添加新行。列数取决于数组第二维的大小，我假设该表具有足够的列。

我的问题是：如何在不使用以下内容的情况下引用表中的范围： a）将具有表格的表格作为活动表格，并且 b）不必引用工作表（就像现在的代码中所示；请参阅下文）？

请参阅下面尝试的代码。

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

那么如何引用表中的“单元格”？

Answer 1

在解决问题的代码下面。

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

将数组粘贴到表中的某些行和列

1 个答案: