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