Vba 填写excel表格的最快方法

我正在开发一个sub，它将从一个表（HeadTable）中获取数据，并将其填入另一个表（AllocatedHeads）中的适当位置。HeadsTable包含按年度划分的员工人数数据。这些人员编制需要按多个利益相关者和资金类型进行划分。AllocatedHeads表将为每个利益相关者和资金类型设置一行，因此Heads表中的一个条目对应AllocatedHeads表中的多个条目（最多30个）。我用excel公式填写的人数本身，但我希望宏填写heads表中的所有说明性数据

我已经创建了一个HeadsEntry类，它保存来自HeadsTable的条目的所有字段数据，以及一个HeadsCollection类，它只是所有HeadsEntry对象的集合

我很高兴展示我的整个sub，但这里展示的内容与我通过迭代集合来填充表格的努力有关。下面的代码是功能性的，但需要很长时间。小时。我的第一次尝试也成功了，并在评论中显示出来。它也花了数小时运行

是否有一种方法可以在更合理的运行时间内完成此任务

    Dim AbsRow As Long

    If [AllocatedHeads].ListObject.ListRows.Count > 0 Then
        'clear table, add one row, get row value
        [AllocatedHeads].ListObject.DataBodyRange.Rows.Delete
        [AllocatedHeads].ListObject.ListRows.Add
        AbsRow = [AllocatedHeads].ListObject.ListRows(1).Range.Row
    End If
    'dimension field column variables
    Dim DescriptionCol As Integer
    Dim LMWBSCol As Integer
    Dim Org1Col As Integer
    Dim Org2Col As Integer
    Dim Org3Col As Integer
    Dim PALS_OSsplitCol As Integer
    Dim ServiceShareRuleCol As Integer
    Dim Heads_IDCol As Integer
    Dim PALS_OSCol As Integer
    Dim ServiceCol As Integer

    'assign column values to variables
    DescriptionCol = [AllocatedHeads[Description]].Column
    LMWBSCol = [AllocatedHeads[LM WBS]].Column
    Org1Col = [AllocatedHeads[Org Tier 1]].Column
    Org2Col = [AllocatedHeads[Org Tier 2]].Column
    Org3Col = [AllocatedHeads[Org Tier 3]].Column
    PALS_OSsplitCol = [AllocatedHeads[PALS/O&S Split]].Column
    ServiceShareRuleCol = [AllocatedHeads[Service Share Rule]].Column
    Heads_IDCol = [AllocatedHeads[Heads_ID]].Column
    PALS_OSCol = [AllocatedHeads[PALS/O&S]].Column
    ServiceCol = [AllocatedHeads[Service]].Column

'    RowNum = 1
    For Each Entry In HeadsCollection.Entries
        For i = 1 To UBound(Entry.PALSOS)
            For j = 1 To UBound(Entry.Service)
'            [AllocatedHeads].ListObject.ListRows.Add
'            AbsRow = [AllocatedHeads].ListObject.ListRows(RowNum).Range.Row
            Cells(AbsRow, DescriptionCol) = Entry.Description
            Cells(AbsRow, LMWBSCol) = Entry.LMWBS
            Cells(AbsRow, Org1Col) = Entry.Org1
            Cells(AbsRow, Org2Col) = Entry.Org2
            Cells(AbsRow, Org3Col) = Entry.Org3
            Cells(AbsRow, PALS_OSsplitCol) = Entry.PALSOSsplit
            Cells(AbsRow, ServiceShareRuleCol) = Entry.ServiceRule
            Cells(AbsRow, Heads_IDCol) = Entry.ID
            Cells(AbsRow, PALS_OSCol) = Entry.PALSOS(i - 1)
            Cells(AbsRow, ServiceCol) = Entry.Service(j - 1)
            AbsRow = AbsRow + 1
'            Set RowRange = [AllocatedHeads].ListObject.ListRows(RowNum).Range
'            Intersect(RowRange, [AllocatedHeads[Description]]) = Entry.Description
'            With Intersect(RowRange, [AllocatedHeads[LM WBS]])
'            .value = Entry.LMWBS
'            .NumberFormat = "@"
'            End With
'            Intersect(RowRange, [AllocatedHeads[Org Tier 1]]) = Entry.Org1
'            Intersect(RowRange, [AllocatedHeads[Org Tier 2]]) = Entry.Org2
'            Intersect(RowRange, [AllocatedHeads[Org Tier 3]]) = Entry.Org3
'            Intersect(RowRange, [AllocatedHeads[PALS/O&S Split]]) = Entry.PALSOSsplit
'            Intersect(RowRange, [AllocatedHeads[Service Share Rule]]) = Entry.ServiceRule
'            Intersect(RowRange, [AllocatedHeads[Heads_ID]]) = Entry.ID
'            Intersect(RowRange, [AllocatedHeads[PALS/O&S]]) = Entry.PALSOS(i - 1)
'            Intersect(RowRange, [AllocatedHeads[Service]]) = Entry.Service(j - 1)
'            RowNum = RowNum + 1
            Next j
        Next i
Next Entry

---

我的解决方案是转换为一个范围，填充单元格，然后转换回一个表。在一个范围内填充单元格要比在表格中快得多。我还利用了这样一个事实，即填充表列中的第一个单元格会将其转换为计算字段。通过在这些字段中使用公式，我减少了输入对象中存储的字段数和需要填写的单元格数。我确信有更快的方法，但这个解决方案将时间从几个小时缩短到了一分钟以下，这足以满足我的需要。下面的代码不显示整个子组件，只显示相关部分

    'determine needed size for Allocated heads table
        AllocatedHeadsRowCount = 0
        For Each Entry In HeadsCollection.Entries
        AllocatedHeadsRowCount = AllocatedHeadsRowCount + (UBound  (Entry.PALSOS) * UBound(Entry.Service))
        Next Entry

    'determine Absolute row (sheet row, instead of listobject row) of first row in table
    Dim AbsRow As Long
    AbsRow = [AllocatedHeads].ListObject.HeaderRowRange.Row + 1

    'delete all table rows
    If [AllocatedHeads].ListObject.ListRows.Count > 0 Then
        'clear table, add one row, get row value
        [AllocatedHeads].ListObject.DataBodyRange.Rows.Delete
    End If

    'assign number values of header row, first table column, number of column
    AllocatedHeadsStartRow = [AllocatedHeads].ListObject.HeaderRowRange.Row
    AllocatedHeadsStartColumn = [AllocatedHeads].ListObject.HeaderRowRange.Column
    AllocatedNumberofColumns = [AllocatedHeads].ListObject.HeaderRowRange.Columns.Count

    'dimension field column variables
    Dim Heads_IDCol As Integer
    Dim PALS_OSCol As Integer
    Dim ServiceCol As Integer

    'assign column values to variables
    Heads_IDCol = [AllocatedHeads[Heads_ID]].Column
    PALS_OSCol = [AllocatedHeads[PALS/O&S]].Column
    ServiceCol = [AllocatedHeads[Service]].Column

    'convert table to range because filling cells in a range is MUCH faster than in a table
    [AllocatedHeads].ListObject.Unlist

    'fill ID, PALS/O&S, and Service columns
    For Each Entry In HeadsCollection.Entries
        For i = 1 To UBound(Entry.PALSOS)
            For j = 1 To UBound(Entry.Service)
            Cells(AbsRow, Heads_IDCol) = Entry.ID
            Cells(AbsRow, PALS_OSCol) = Entry.PALSOS(i - 1)
            Cells(AbsRow, ServiceCol) = Entry.Service(j - 1)
            AbsRow = AbsRow + 1
            Next j
        Next i
    Next Entry

    'convert back to table
    With Sheets("Allocated Heads").ListObjects.Add(xlSrcRange, Range(Cells(AllocatedHeadsStartRow, AllocatedHeadsStartColumn), Cells(AllocatedHeadsStartRow + AllocatedHeadsRowCount, AllocatedHeadsStartColumn + AllocatedNumberofColumns - 1)), , xlYes)
    .Name = "AllocatedHeads"
    .TableStyle = "TableStyleMedium7"
    End With

    'add formulas to the first cell in columns for which the data is the same as in the heads table.
    'This creates a calculated column and will fill down
    [AllocatedHeads].ListObject.ListColumns("Service Share Rule").DataBodyRange = "=LOOKUP(AllocatedHeads[@[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Service Share Rule]:[Service Share Rule]])"
    [AllocatedHeads].ListObject.ListColumns("PALS/O&S Split").DataBodyRange = "=LOOKUP(AllocatedHeads[@[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[PALS/O&S Split]:[PALS/O&S Split]])"
    [AllocatedHeads].ListObject.ListColumns("Org Tier 1").DataBodyRange = "=LOOKUP(AllocatedHeads[@[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 1]:[Org Tier 1]])"
    [AllocatedHeads].ListObject.ListColumns("Org Tier 2").DataBodyRange = "=LOOKUP(AllocatedHeads[@[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 2]:[Org Tier 2]])"
    [AllocatedHeads].ListObject.ListColumns("Org Tier 3").DataBodyRange = "=LOOKUP(AllocatedHeads[@[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Org Tier 3]:[Org Tier 3]])"
    [AllocatedHeads].ListObject.ListColumns("LM WBS").DataBodyRange = "=LOOKUP(AllocatedHeads[@[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[LM WBS]:[LM WBS]])"
    [AllocatedHeads].ListObject.ListColumns("Description").DataBodyRange = "=LOOKUP(AllocatedHeads[@[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[[Description]:[Description]])"
    [AllocatedHeads].ListObject.ListColumns("2009").DataBodyRange = "=LOOKUP(AllocatedHeads[@[Heads_ID]:[Heads_ID]],HeadsTable[[ID]:[ID]],HeadsTable[2009])*SUMPRODUCT((AllocatedHeads[@[PALS/O&S Split]:[PALS/O&S Split]] = SplitTable[[Split Name]:[Split Name]])*(AllocatedHeads[@[PALS/O&S]:[PALS/O&S]] = SplitTable[[PALS/O&S]:[PALS/O&S]])*SplitTable[2009])*SUMPRODUCT((AllocatedHeads[@[Service Share Rule]:[Service Share Rule]]=SplitTable[[Split Name]:[Split Name]])*(AllocatedHeads[@[Service]:[Service]]=SplitTable[[Service]:[Service]])*SplitTable[2009])"

    'Fill years columns by first drragging across(to have appropriate column references),
    'then copy pasting in place in order to create calculated columns
    Dim FirstCell As Range
    Dim FillRange As Range
    Set FirstCell = Intersect([AllocatedHeads].ListObject.DataBodyRange.Rows(1), [AllocatedHeads[2009]])
    Set FillRange = Range(FirstCell.Address, Cells(FirstCell.Row, [AllocatedHeads].ListObject.Range.SpecialCells(xlLastCell).Column))
    FirstCell.AutoFill FillRange, xlFillDefault
    FillRange.Copy
    FirstCell.PasteSpecial xlPasteFormulas

    'create calculated column in Total column
    [AllocatedHeads].ListObject.ListColumns("Total").DataBodyRange = "=SUM(" & FirstCell.Address(False, False) & ":" & Cells(FirstCell.Row, [AllocatedHeads].ListObject.Range.SpecialCells(xlLastCell).Column).Address(False, False) & ")"

---

有多少行？HeadTable当前包含175行，AllocatedHeads表中的行数略多于4000行。我认为一个数据样本可能有助于明确您在这里所做的工作。如果您将表写入预先标注的数组，然后在一个步骤中将其写入工作表范围，速度会快得多。e、 g:

redimv（1到numrows，1到numcolumns）

；然后填充所有单元格；然后

Range（cell_ref）。调整大小（ubound（v，1），ubound（v，2））。Value=v

这是一种可能性。我希望这样做，AllocatedHeads表列的排列方式不必与HeadTable相同。我认为您的解决方案不允许这样做，但这样设置可能值得。