VBA：从一个工作到另一个带有“移动范围”

Question

我试图创建我的库存系统的仪表盘传输数据。仪表板将显示当天的销售（类别1），需要购买的产品（类别2），预期的采购订单（类别3）和在制品（类别4）。对于这个问题，我只关注类别2，需要进行的采购。

我试图将所有的数据从工作表转移（“采购”）的仪表板下方2.我试图使用命名范围做这一类，因为每个类别的范围内会波动的项目添加/删除。您可以在here中找到我正在处理的工作簿示例 - 它位于excelforum.com上。

下面的代码是我到目前为止所。它在一定程度上起作用，但Range（“PurchaseStart”），即Cell $ A $ 8，起始于A：1。我不知道如何选择我正在寻找的命名范围。我在每行末尾添加了“End＃”语句以表示截断，并希望能够擅长仅选择特定类别的范围。

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 

Answer 1

你可以做线沿线的东西： （假设每个数据段的开头已制定了一些标题，即“需要进行”，然后在下面这头是数据的该部分去）：

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 = Cells(f.row - 1, 1)。

Answer 2

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

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