使用VBA向SharePoint工作表表格粘贴新行时表格未自动扩展

我编写了如下VBA代码，用于向SharePoint中的工作表表格粘贴新行。但将内容粘贴至下一个空白行时，表格并未动态扩展。

Sub Complete()
    
    Dim tb1 As ListObject, tb2 As ListObject, tbl As ListObject
    Dim Lrow As Long, dRow As Long
    Dim ws As Worksheet, ws1 As Worksheet
    Dim searchRange As Range, foundCell As Range
    Dim mysearch As String
    Dim wb As Workbook, Scwb As Workbook
    Dim ScRow As Range
    
    Application.DisplayAlerts = False
    
    Set wb = ThisWorkbook
    mysearch = Sheets("OI").Range("D4").Value
    
    Set ws = wb.Sheets("OI")
    Set tb1 = ws.ListObjects("OITs")
    Set tb2 = wb.Sheets("TDets").ListObjects("OIFinal")
    Lrow = tb2.ListRows.Count
    
    With ws
        .Range("A:A").EntireColumn.Hidden = False
    End With
    
    tb1.Range.AutoFilter Field:=11, Criteria1:="<>" & vbNullString
    NumRows = tb1.DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Rows.Count
    tb1.DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Copy
    tb2.DataBodyRange(Lrow + 1, 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    tb1.DataBodyRange.Columns(4).Resize(, 7).ClearContents
    tb1.Range.AutoFilter Field:=11, Criteria1:="=" & vbNullString
    
    With ws
        .Range("A:A").EntireColumn.Hidden = True
    End With
    
    With wb.Sheets("CReqs")
        Set searchRange = .Range("G1", .Range("G" & .Rows.Count).End(xlUp))
    End With
    
    Set Scwb = Workbooks.Open("https://*****.sharepoint.com/sites/*****/Shared%20Documents/General/NAA/Apps.xlsx")
    Set tbl = Scwb.Sheets("AppAccs").ListObjects("Pending")
    dRow = tbl.Range.Rows.Count
    
    Set foundCell = searchRange.Find(what:=mysearch, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not foundCell Is Nothing Then
        foundCell.Offset(0, 6).Value = "Yes"
        foundCell.Offset(0, -6).EntireRow.Copy Destination:=tbl.Range(dRow, "A").Offset(1) ' 问题出在这里：直接粘贴到表格外，表格不扩展
        Scwb.Save
        Scwb.Close
    Else
        MsgBox "We cannot find the ID " & mysearch & " to send for approval. Please check ID."
    End If
    
    Application.DisplayAlerts = True
    
End Sub

问题原因 #

直接将行复制粘贴到表格下方的空白行时，Excel不会自动将该行纳入表格范围，因此表格不会动态扩展。正确的做法是通过ListObject.ListRows.Add方法向表格添加新行，再将数据复制到新行中。

修改方案 #

替换代码中负责粘贴到SharePoint表格的关键代码段：

原代码行：

foundCell.Offset(0, -6).EntireRow.Copy Destination:=tbl.Range(dRow, "A").Offset(1)

替换为：

Dim newRow As ListRow
' 向表格末尾添加新行，AlwaysInsert:=True确保强制插入行并扩展表格
Set newRow = tbl.ListRows.Add(AlwaysInsert:=True)
' 复制目标行中与表格列数匹配的内容，避免列数不匹配的问题
foundCell.Offset(0, -6).Resize(1, tbl.ListColumns.Count).Copy
' 将内容粘贴到新行，可根据需求选择粘贴类型（这里用值粘贴）
newRow.Range.PasteSpecial xlPasteValues

补充说明 #

• 使用ListRows.Add方法会直接将新行纳入表格结构，确保表格自动扩展；
• 用Resize(1, tbl.ListColumns.Count)限制复制的列数与表格列数一致，避免因复制整行导致的列溢出问题；
• 若需要保留格式等其他内容，可修改PasteSpecial的参数（如xlPasteAll）。

内容的提问来源于stack exchange，提问作者MBrann