如何在动态 Excel ListObject 表中填充数据？

Question

对于项目组合资源报告，我需要将平面数据工作表中的数据汇总到 ListObject 表中。今天，这个过程是在 VBA 中“静态”完成的，例如当在任一单元表（见下图）中添加新资源时，还必须通过添加新单元格引用手动更新“静态”VBA。我需要使这个过程动态化。

静态代码通过将单元格公式从每个表格的第一个单元格（总共 7 个表格）复制到表格中的其他单元格来利用 ListObject 表格​​功能。

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

（这两个文件都可以从这里进行 DL：https://gofile.io/d/GL86kd）当工作簿打开时，ListObject 表会自动更新，如下所示：

用作数据源的平面数据表如下所示（每个项目的结构完全相同，即随着项目的数量重复）：

Answer 1

我想出了一个简单的循环解决方案。它仍然结合使用 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