VBA：「移動範囲」のあるワークシートから別のワークシートへのデータの転送

Question

在庫システムのダッシュボードを作成しようとしています。ダッシュボードには、その日の売上（カテゴリ1）、購入が必要な購入（カテゴリ2）、予想される購買発注（Cateogry 3）、仕掛品（カテゴリ4）が表示されます。この質問では、カテゴリ2、購入が必要な購入のみに焦点を絞るつもりです。

ワークシート（「購入」）からカテゴリ2のダッシュボードにすべてのデータを転送しようとしています。これは、各カテゴリの範囲がアイテムによって変動するため、名前付き範囲を使用しようとしています。追加/削除されました。私はhereで働いているワークブックのサンプルを見つけることができます - それはexcelforum.comにあります。

以下のコードは私がこれまで持っているものです。これはある程度は機能しますが、Cell $ A $ 8のRange（ "PurchaseStart"）は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