excel 使用VBA将新行粘贴到下一个空行中不会扩展表

scyqe7ek  于 2023-06-25  发布在  其他
关注(0)|答案(1)|浏览(188)

我有下面的代码来粘贴一个新的行到一个表中的一个新的工作表在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) ' This is the line that pastes the code to a new wb but does not expand the table.
        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
9lowa7mx

9lowa7mx1#

我已经解决了上述问题,只需在粘贴到新的SP工作簿后将tbl.Resize tbl.Range.CurrentRegion添加到下一行

相关问题