我正在处理一个sub，它将从一个表（HeadsTable）中获取数据并将其填充到另一个表（AllocatedHeads）中的适当位置。 HeadsTable包含按年份计算的人数。这些人数需要由许多利益相关者和资金类型分开。 AllocatedHeads表将为每个利益相关者和资金类型分配一行，因此HeadsTable中的一个条目对应于AllocatedHeads表中的多个（最多30个）。人员我自己用excel公式填写，但我希望宏填写head表中的所有描述性数据。
我创建了一个HeadsEntry类，它保存了HeadsTable和HeadsCollection类的所有字段数据，HeadCollection类只是所有HeadsEntry对象的集合。
我很高兴展示我的整个潜艇，但这里显示的是我通过迭代HeadsCollection来填补表格的努力。下面的代码是功能性的，但需要很长时间。小时。我的第一次尝试也奏效了，并在评论中显示。它还需要数小时才能运行。
有没有办法在更合理的运行时间内完成这项任务？
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
答案 0 :(得分：0)
我的解决方案是转换为范围，填写单元格，然后转换回表格。填充范围内的单元格比表格中的快得多。我还利用了填充表格列中的第一个单元格将其转换为计算字段的事实。通过在这些字段中使用公式，我减少了我在Entry对象中存储的字段数量以及我需要填写的单元格数量。我确信有更快的方法，但是这个解决方案可以将它从几个小时缩短到几个小时一分钟，这足以满足我的需求。代码beow不显示整个sub，只显示相关部分。
'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) & ")"