VBA：使用“移动范围”将数据从一个工作表传输到另一个工作表

我正在尝试创建库存系统的仪表板。仪表板将显示当天类别1的销售额、类别2需要进行的采购、类别3预期的采购订单以及流程类别4。对于这个问题，我只将重点放在第2类，即需要进行的购买

我正在尝试将所有数据从WorksheetsPurchasing传输到类别2下的仪表板。我尝试使用命名范围来实现这一点，因为每个类别的范围都会随着项目的添加/删除而波动。您可以在excelforum.com上找到我正在编写的工作簿示例

下面的代码是我到目前为止的代码。它在一定程度上是有效的，但是RangePurchaseStart，即单元格$a$8，从a:1开始。我不知道如何只选择我要查找的命名范围。我在每行的末尾添加了结束语句，以表示一个截止点，并希望欺骗excel只选择特定类别的范围

Option Explicit

Sub purchPull()

Dim Dashboard As Worksheet
Dim Purchasing As Worksheet
Dim PM As Range, D As Range, Rng As Range
Dim purchName As Range

Set Purchasing = Worksheets("Purchasing")
Set Dashboard = Worksheets("Dashboard")


' Go through each Item in Purchasing and check to see if it's anywhere      within the named range "PurchaseStart"
' In this case it should be "A8:A9" - as there is nothing in the dasboard yet
For Each PM In Purchasing.Range(Purchasing.Cells(1, 1),     Purchasing.Cells(Purchasing.Rows.Count, 1).End(xlUp))
    With Dashboard.Range("PurchaseStart",   Dashboard.Cells(Dashboard.Rows.Count, 1))
    Set Rng = .Find(What:=PM.Offset(0, 1), _
        After:=.Cells(.Cells.Count), _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False)
    If Not Rng Is Nothing Then
        ' Do nothing, as we don't want duplicates
    Else
        ' From the start of the named range, transfer data over - THIS IS THE PROBLEM AREA
        With Dashboard.Range("PurchaseStart", Dashboard.Cells(.Rows.Count, 1)).End(xlUp)
            .Offset(1, 1) = PM.Offset(0, 0) ' Order Number
            .Offset(1, 2) = PM.Offset(0, 1) ' SKU
            .Offset(1, 3) = PM.Offset(0, 3) ' Qty
            .Offset(1, 4) = PM.Offset(0, 4) ' Date
        End With
    End If
End With
Next

End Sub

---

您可以按照以下思路做一些事情： 这假设每个数据节的开头都有一些标题，即需要制作，然后在该标题下方是该节的数据所在位置：

Sub findDataStartRow()
Dim f as Range, dataStartRange as Range

Set f = Columns(1).Find(what:="Need to be made", lookat:xlWhole)
If Not f is Nothing Then
    dataStartRange = Cells(f.row + 1, 1) 'Do stuff with this range... maybe insert rows below it to start data
Else: Msgbox("Not found")
    Exit Sub
End if
End Sub

对每个部分做类似的操作。这样，无论报头放在哪里，也不管数据应该放在哪里的开头，都会在报头的正下方有一个命名的位置范围。

---

或者，如果您想将数据添加到节的末尾，只需在下面找到您希望数据所在的节的标题，并在正确修改.find后设置dataStartRange=Cellsf.row-1，1即可。

我找到了答案。我认为这是一个很好的解决问题的方法，但是如果有人能想出更好的方法，我很乐意听到。谢谢大家的帮助

Option Explicit

Sub purchPull()

Dim Dashboard As Worksheet
Dim Purchasing As Worksheet
Dim PM As Range, D As Range, Rng As Range
Dim purchName As Range
Dim lastRow As Long
Dim firstRow As Long

Set Purchasing = Worksheets("Purchasing")
Set Dashboard = Worksheets("Dashboard")

' first row of named range "PurchaseStart"
firstRow = Dashboard.Range("PurchaseStart").Row +     Dashboard.Range("PurchaseStart").Rows.Count



' Go through each Item in Purchasing and check to see if it's anywhere within the named range "PurchaseStart"
With Purchasing
For Each PM In Purchasing.Range(Purchasing.Cells(2, 1), Purchasing.Cells(Purchasing.Rows.Count, 1).End(xlUp))
    With Dashboard.Range("PurchaseStart", Dashboard.Cells(Dashboard.Rows.Count, 1))
        Set Rng = .Find(What:=PM.Offset(0, 0), _
            After:=.Cells(.Cells.Count), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False)
        If Not Rng Is Nothing Then
            ' Do nothing, as we don't want duplicates
        Else      
            ' Identify the last row within the named range "PurchaseStart"
            lastRow = Dashboard.Range("PurchaseStart").Cells(1, 1).End(xlDown).Row
            ' Transfer the data over
            With Dashboard.Cells(lastRow, 1).End(xlUp)
                .Offset(1, 0).EntireRow.Insert
                .Offset(1, 0) = PM.Offset(0, 0)  ' Order Number
                .Offset(1, 1) = PM.Offset(0, 1) ' SKU
                .Offset(1, 2) = PM.Offset(0, 2) ' Qty
                .Offset(1, 3) = PM.Offset(0, 3) ' Date
            End With
        End If
    End With
Next
End With

End Sub