1つのシートから別のシートに複数の（ただしすべてではない）行と列のセル値をコピーする方法

Question

いくつかのオプションを選択した後に（選択した）Excelツールを開発しました。製品を顧客に提供します。

ユーザが使用するワークシート（つまり「Particulier」）は、他のいくつかのシートからデータを取得します。これらのシートの1つは価格リスト（すなわち「Toestelprijzen Start」）であり、毎回更新する必要があります：毎週、私はExcelツールで古い価格を更新するために使用する新しい製品価格で新しい価格リストを受け取ります。そうするために、私は完全に正常に動作し、次のコードを使用します。

Sub ImportPrijslijstStart() 
    Dim sImportFile As String, sFile As String 
    Dim sThisBk As Workbook 
    Dim vfilename As Variant 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Set sThisBk = ActiveWorkbook 
    sImportFile = Application.GetOpenFilename(_ 
    FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook") 
    If sImportFile = "False" Then 
     MsgBox "No File Selected!" 
     Exit Sub 
    Else 
     vfilename = Split(sImportFile, "\") 
     sFile = vfilename(UBound(vfilename)) 
     Application.Workbooks.Open Filename:=sImportFile 

     Set wbBk = Workbooks(sFile) 
     With wbBk 
      If SheetExists("VF Start incl. BTW") Then 
       Set wsSht = .Sheets("VF Start incl. BTW") 
       wsSht.Copy before:=sThisBk.Sheets("Toestelprijzen Start") 
      Else 
       MsgBox "Er is geen sheet met de naam VF Start incl. BTW in:"&vbCr& .Name 
      End If 
      wbBk.Close SaveChanges:=False 
     End With 
    End If 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    MsgBox "Prijslijst geïmporteerd" 
End Sub 

Private Function SheetExists(sWSName As String) As Boolean 
    Dim ws As Worksheet 
    On Error Resume Next 
    Set ws = Worksheets(sWSName) 
    If Not ws Is Nothing Then SheetExists = True 
End Function 

この新しい輸入価格表の各製品（350品目）がオプションが「パティキュリエ」のワークシート上で選択されているかに応じて異なる価格を持っています。つまり、この価格表の各製品には31種類の価格があります。

最初の2列（A & B）の製品番号が表示され、3列目（C）に製品名が表示され、列D：AHに製品価格が表示されます。次に、見出しが行1-6にあり、製品価格が行7から始まります。したがって、この新しいインポートされたシートにセルA1：AH357のデータがあり、セルD7：AH357に商品価格が表示されます。

ただし、新しい商品が追加され、古い商品が新しい価格表から削除されることがあります。これは、行357が必ずしも最後の行ではないことを意味します。次に、この新しいインポートされたワークシートの価格を古い価格のワークシートにコピー（すなわち、「更新」）したいと考えています。

この新しい価格表では、異なる色の製品が何度か表示されるため、新しいワークシートから価格をコピーします。各色は、一意の製品番号を持つ固有の製品として表示されますが、各色ごとに同じ価格が表示されます。

ただし、商品Xは黒、白、金、ピンクになりますが、商品Xの価格は色に関係なく同じですので、列Dの価格：これら4色のうちの1つからのAH）。これを行うには、VLOOKUPを使用して、古い価格表と新しい価格表の両方で使用されている固有の製品番号を検索します。

しかし、私のコードは私が望むように動作しません。 31列のD：AHではなく、1つの列のみをコピーします。また、すべての情報を2回コピーします。つまり、第1列（D）の値（価格）を新しくインポートされた価格リストから古い価格（価格を更新する）のシートに、例えば行7から検索し（コピーする）行87（一意の製品番号を持つ80個の項目があるため80行のみ）が、その後、88行目から168行目にすべてのデータ（価格）が2番目に貼り付けられます。

さらに、約40秒で終了する。私が探しています

を終了する

• コピーの1列のみからのデータではなく31列
• ペーストデータは二回
• はとても時間がかかる：私は私のコードは、なぜ全く見当もつかないこれらの3つの問題を解決するのに役立ちます。

  私が使用したコードの下に見つけてください：私は、可能な限り明確な状況を説明しようとした

  Sub PrijslijstUpdatenStart() 
      Dim Osh As Worksheet 
      'Sheet with the new product prices: 
      Set Osh = ThisWorkbook.Sheets("VF Start incl. BTW") 
      Dim Orange As String 
      Dim Olength As Integer 
      Olength = Osh.Range("B1", Osh.Range("B7").End(xlDown)).Rows.Count 
      Orange = "B7:AH" & Olength  
      Dim Nsh As Worksheet 
      'Sheet on which the old prices are displayed that need to be updated with the 
      ' new prices on "VF Start incl. BTW": 
      Set Nsh = ThisWorkbook.Sheets("Toestelprijzen Start") 
      Dim Nrange As String 
      Dim Nlength As Integer 
      Nlength = Nsh.Range("B1", Nsh.Range("B10").End(xlDown)).Rows.Count 
      Nrange = "B10:AG" & Nlength 
      On Error Resume Next 
      Dim Dept_Row As Long 
      Dim Dept_Clm As Long 
      Table1 = Nsh.Range(Nrange) 
      Table2 = Osh.Range(Orange) 
      Dept_Row = Nsh.Range("E10:AH" & Olength).Row 
      Dept_Clm = Nsh.Range("E10:AH" & Olength).Column 
      For Each cl In Table1 
       Nsh.Cells(Dept_Row, Dept_Clm) = _ 
          Application.WorksheetFunction.VLookup(cl, Table2, 2, False) 
       Dept_Row = Dept_Row + 1 
      Next cl 
  End Sub 
  

  。詳しい情報が必要な場合は、私に知らせてください。

Answer 1

ここでは、辞書を使用して、製品名をキーとして、新しい値を最初のワークシートの配列として保存します。次に、2番目のワークシートを反復処理し、一致が見つかった場合は、隣接する列に値の配列を割り当てます。

Sub PrijslijstUpdatenStart() 
    Application.ScreenUpdating = False 
    Dim dict As Object 
    Set dict = CreateObject("Scripting.Dictionary") 

    With ThisWorkbook.Sheets("VF Start incl. BTW") 
     For Each r In .Range("B7", .Range("B7").End(xlDown)) 
      If Not dict.Exists(r.Value) Then dict.Add r.Value, r.Offset(0, 1).Resize(1, 31).Value 
     Next 
    End With 

    With ThisWorkbook.Sheets("Toestelprijzen Start") 
     For Each r In .Range("B10", .Range("B10").End(xlDown)) 
      If dict.Exists(r.Value) Then r.Offset(0, 1).Resize(1, 31).Value = dict(r.Value) 
     Next 
    End With 
    Application.ScreenUpdating = True 
End Sub 

更新：新しい価格表から欠落している、古い製品を削除します。 .Row`と `Dept_Clm = Nsh.Range（「E10：私の知る限り見ることができるように

---

Sub PrijslijstUpdatenStart() 
    Application.ScreenUpdating = False 
    Dim x As Long 
    Dim dict As Object 
    Set dict = CreateObject("Scripting.Dictionary") 

    With ThisWorkbook.Sheets("VF Start incl. BTW") 
     For Each r In .Range("B7", .Range("B7").End(xlDown)) 
      If Not dict.Exists(r.Value) Then dict.Add r.Value, r.Offset(0, 1).Resize(1, 31).Value 
     Next 
    End With 

    With ThisWorkbook.Sheets("Toestelprijzen Start") 
     For x = .Range("B10").End(xlDown).Row To 10 Step -1 
      If dict.Exists(.Cells(x, "B").Value) Then 
       .Cells(x, "C").Offset(0, 1).Resize(1, 31).Value = dict(.Cells(x, "C").Value) 
      Else 
       .Rows(x).Delete 
      End If 
     Next 
    End With 
    Application.ScreenUpdating = True 
End Sub