如何在动态Excel ListObject表中填充数据?
对于项目组合资源报告,我需要将平面数据工作表中的数据汇总到ListObject表中。如今,该过程是在VBA中“静态”完成的,例如,当在任一单位表中添加一个新资源(参见图片be low)时,“静态”VBA也必须通过添加新的单元格引用手动更新。我需要让这个过程充满活力 静态代码利用ListObject表功能,将单元格公式从每个表的第一个单元格(总共7个表)复制到表中的其他单元格如何在动态Excel ListObject表中填充数据?,excel,vba,Excel,Vba,对于项目组合资源报告,我需要将平面数据工作表中的数据汇总到ListObject表中。如今,该过程是在VBA中“静态”完成的,例如,当在任一单位表中添加一个新资源(参见图片be low)时,“静态”VBA也必须通过添加新的单元格引用手动更新。我需要让这个过程充满活力 静态代码利用ListObject表功能,将单元格公式从每个表的第一个单元格(总共7个表)复制到表中的其他单元格 Sub FormaterResArk() Dim List As Excel.ListObject Applicati
Sub FormaterResArk()
Dim List As Excel.ListObject
Application.ScreenUpdating = False
Ark3.Cells.ClearContents ‘Ark3 is the Resource report worksheet where the ListObject tables reside
'********** Static code **********
Range("G3").Select
ActiveCell.FormulaR1C1 = _
‘ResSkyggeArk is the flat datafile worksheet name
"=ResSkyggeArk!RC+ResSkyggeArk!R[119]C+ResSkyggeArk!R[238]C+ResSkyggeArk!R[357]C+ResSkyggeArk!R[476]C+ResSkyggeArk!R[595]C+ResSkyggeArk!R[714]C+ResSkyggeArk!R[833]C+ResSkyggeArk!R[952]C"
Range("G3").Select
Selection.Copy
Range("H3:R3").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("G14").Select
ActiveCell.FormulaR1C1 = _
"=ResSkyggeArk!RC+ResSkyggeArk!R[119]C+ResSkyggeArk!R[238]C+ResSkyggeArk!R[357]C+ResSkyggeArk!R[476]C+ResSkyggeArk!R[595]C+ResSkyggeArk!R[714]C+ResSkyggeArk!R[833]C+ResSkyggeArk!R[952]C"
Range("G14").Select
Selection.Copy
Range("H14:R14").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("G27").Select
ActiveCell.FormulaR1C1 = _
"=ResSkyggeArk!RC+ResSkyggeArk!R[119]C+ResSkyggeArk!R[238]C+ResSkyggeArk!R[357]C+ResSkyggeArk!R[476]C+ResSkyggeArk!R[595]C+ResSkyggeArk!R[714]C+ResSkyggeArk!R[833]C+ResSkyggeArk!R[952]C"
Range("G27").Select
Selection.Copy
Range("H27:R27").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("G59").Select
ActiveCell.FormulaR1C1 = _
"=ResSkyggeArk!RC+ResSkyggeArk!R[119]C+ResSkyggeArk!R[238]C+ResSkyggeArk!R[357]C+ResSkyggeArk!R[476]C+ResSkyggeArk!R[595]C+ResSkyggeArk!R[714]C+ResSkyggeArk!R[833]C+ResSkyggeArk!R[952]C"
Range("G59").Select
Selection.Copy
Range("H59:R59").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("G71").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=ResSkyggeArk!RC+ResSkyggeArk!R[119]C+ResSkyggeArk!R[238]C+ResSkyggeArk!R[357]C+ResSkyggeArk!R[476]C+ResSkyggeArk!R[595]C+ResSkyggeArk!R[714]C+ResSkyggeArk!R[833]C+ResSkyggeArk!R[952]C"
Range("G71").Select
Selection.Copy
Range("H71:R71").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("G80").Select
ActiveCell.FormulaR1C1 = _
"=ResSkyggeArk!RC+ResSkyggeArk!R[119]C+ResSkyggeArk!R[238]C+ResSkyggeArk!R[357]C+ResSkyggeArk!R[476]C+ResSkyggeArk!R[595]C+ResSkyggeArk!R[714]C+ResSkyggeArk!R[833]C+ResSkyggeArk!R[952]C"
Range("G80").Select
Selection.Copy
Range("H80:R80").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("G92").Select
ActiveCell.FormulaR1C1 = _
"=ResSkyggeArk!RC+ResSkyggeArk!R[119]C+ResSkyggeArk!R[238]C+ResSkyggeArk!R[357]C+ResSkyggeArk!R[476]C+ResSkyggeArk!R[595]C+ResSkyggeArk!R[714]C+ResSkyggeArk!R[833]C+ResSkyggeArk!R[952]C"
Range("G92").Select
Selection.Copy
Range("H92:R92").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'********** Marks resource if > 135 hrs red and hrs between 128 og 134,9 yellow **********
Range("G3:R11,G14:R24,G27:R56,G59:R68,G71:R77,G80:R89,G92:R113").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
Formula1:="=135"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
Formula1:="=128", Formula2:="=134,9"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
'********** Hides filter-buttons from tables **********
For Each List In Ark3.ListObjects
List.ShowAutoFilterDropDown = False
Next
Application.ScreenUpdating = True
End Sub
(两个文件都可以从此处删除:)打开工作簿时,ListObject表会自动更新,如下所示:
用作数据源的平面数据表如下所示(每个项目的结构完全相同,即,它随着项目的数量而重复):
我想出了一个简单的循环解决方案。它仍然将ListObject表属性与FormulaR1C1的功能结合使用。公式本身很长,但我在这里也尝试了各种嵌套循环,但都失败了。代码如下:
Sub LavSamletResArk()
Dim WS As Worksheet
Dim tbl As ListObject
Dim sidsteraekke As Long
Dim X As Long
Dim r As Long
Set WS = Ark3
'Find the last row number of the resource report
sidsteraekke = Ark3.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
r = sidsteraekke
'Write formula into cells
For Each tbl In WS.ListObjects
For X = 1 To tbl.ListRows.count
tbl.Range.Cells(2, 7).Select
ActiveCell.FormulaR1C1 = "=ResSkyggeArk!RC+ResSkyggeArk!R[" & r & _
"]C+ResSkyggeArk!R[" & 2 * r & "]C+ResSkyggeArk!R[" & 3 * r & _
"]C+ResSkyggeArk!R[" & 4 * r & "]C+ResSkyggeArk!R[" & 5 * r & _
"]C+ResSkyggeArk!R[" & 6 * r & "]C+ResSkyggeArk!R[" & 7 * r & _
"]C+ResSkyggeArk!R[" & 8 * r & "]C+ResSkyggeArk!R[" & 9 * r & _
"]C+ResSkyggeArk!R[" & 10 * r & "]C+ResSkyggeArk!R[" & 11 * r & _
"]C+ResSkyggeArk!R[" & 12 * r & "]C+ResSkyggeArk!R[" & 13 * r & _
"]C+ResSkyggeArk!R[" & 14 * r & "]C+ResSkyggeArk!R[" & 15 * r & "]C _
+ResSkyggeArk!R[" & 16 * r & "]C+ResSkyggeArk!R[" & 17 * r & _
"]C+ResSkyggeArk!R[" & 18 * r & "]C+ResSkyggeArk!R[" & 19 * r & _
"]C+ResSkyggeArk!R[" & 20 * r & "]C+ResSkyggeArk!R[" & 21 * r & _
"]C+ResSkyggeArk!R[" & 22 * r & "]C+ResSkyggeArk!R[" & 23 * r & "]C _
+ResSkyggeArk!R[" & 24 * r & "]C+ResSkyggeArk!R[" & 25 * r & "]C"
ActiveCell.Copy
ActiveCell.Offset(0, 1).Select
Range(ActiveCell, Selection.End(xlToRight)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Exit For
Next X
Next tbl
End Sub