我有下面的代码来粘贴一个新的行到一个表中的一个新的工作表在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
1条答案
按热度按时间9lowa7mx1#
我已经解决了上述问题,只需在粘贴到新的SP工作簿后将tbl.Resize tbl.Range.CurrentRegion添加到下一行