Question

我需要解决DataBodyRange的问题，这是没有错。

我正在尝试将数据从已过滤的源表复制到目标表。目标表数据将用于下拉菜单。

当我清除Target表以准备粘贴下一个Source数据时，有时会出现运行时错误，这是基于DataBodyRange为Nothing造成的。

我知道当DataBodyRange有东西时如何粘贴数据。

当DataBodyRange为Nothing时，我需要代码将源数据粘贴到目标表中。

请参阅下面的ELSE声明。

Sub Copy_With_AutoFilter()

Dim loSource As Excel.ListObject
Dim loTarget As Excel.ListObject
Dim SourceDataRowsCount As Long
Dim TargetDataRowsCount As Long
Dim myfilter As Range
Dim rng As Range
Dim EndRow As ListRow

'Change ScreenUpdating, Calculation, EnableEvents, etc.
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    ActiveSheet.DisplayPageBreaks = False

'Prepare to Copy Specific Data from Source Table
Set loSource = Sheets("ProductData").ListObjects("tblProductData")
Set myfilter = Range("ShipToNumber")

'Create the Filter for the Source Table & Count Number of Cells
    loSource.Range.AutoFilter Field:=3, Criteria1:=myfilter
    SourceDataRowsCount = loSource.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Count

'Prepare to Paste that Data in Target Table
Set loTarget = Sheets("ProductData").ListObjects("tblMyProducts")

'Delete all Target table rows
    If Not loTarget.DataBodyRange Is Nothing Then
           loTarget.DataBodyRange.Delete
           loTarget.Resize Range("$J$1:$Q$2")
    End If

'Setup the Target Table
    If SourceDataRowsCount <> 0 Then
        Set rng = Range("tblMyProducts[#All]").Resize(SourceDataRowsCount + 1, 8)
        loTarget.Resize rng

'Copy Data from Source Table to Target Table
        loSource.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy

'Check to see if there is data in table
    If Not loTarget.DataBodyRange Is Nothing Then
        loTarget.DataBodyRange.PasteSpecial (xlPasteValues)
    Else
        'Set EndRow = loTarget.ListRows.Add
        'NEED HELP HERE:  Code to Add the Copied Rows from the Source table when DatabodyRange is Nothing
    End If

'Restore ScreenUpdating, Calculation, EnableEvents, etc.
        Sheets("ProductData").ListObjects("tblProductData").ShowAutoFilter = False
        Application.CutCopyMode = False
        ActiveWindow.View = ViewMode
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    Else
        MsgBox "Sorry, this Ship To location has not ordered any products in the last six months.  Please contact customer service so that your tables can be updated."
    End If

End Sub

谢谢。

迈克尔

Answer 1

我认为您需要做的是首先插入一行。这是一个简单的示例，希望您可以进行调整（表1包含3列）。

Sub x()

Dim l As ListObject

Set l = Sheets(1).ListObjects("Table1")
If l.DataBodyRange Is Nothing Then
    l.ListRows.Add
    Range("F1:H1").Copy l.DataBodyRange(1, 1)
End If

End Sub

当DataBodyRange为Nothing时，将VBA从源表复制/粘贴到目标表中

1 个答案: