一部のセルが一致すると、範囲を比較して行全体をコピーしますか？

Question

2つの異なるシートで2つの範囲を比較したいと思います。

Sheet1("Raport")には、入手すべき顧客情報と種類が記載されています。
Sheet2("Dane")（1件のカスタマー=行全体として）（特定のシートにコピーされなければならない顧客に関する詳細情報が含まれ、例えばSheet3("Produkt1")、Sheet4("Produkt2")など、空の行を削除し、顧客との製品リスト（Sheet1("Raport")）。

に基づいて（作品）Produkt1の

Sub DeleteBlankRows1() 
    Dim i As Long 

    With Application 
     .Calculation = xlCalculationManual 
     .ScreenUpdating = False 

     For i = Selection.Rows.Count To 1 Step -1 
      If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then 
       Selection.Rows(i).EntireRow.Delete 
      End If 
     Next i 

     .Calculation = xlCalculationAutomatic 
     .ScreenUpdating = True 
    End With 
End Sub 

レンジProdukt2の（作品）

Sub SelectBetween() 
    Dim findrow As Long, findrow2 As Long 

    findrow = Range("B:B").Find("Produkt1", Range("B1")).Row 
    findrow2 = Range("B:B").Find("Laczna ilosc Produkt1", Range("B" & findrow)).Row 
    Range("B" & findrow + 1 & ":M" & findrow2 - 1).Select 
End Sub 

レンジ（作品）

Sub SelectBetween2() 
    Dim findrow As Long, findrow2 As Long 

    findrow = Range("B:B").Find("Produkt2", Range("B1")).Row 
    findrow2 = Range("B:B").Find("Laczna ilosc Produkt2", Range("B" & findrow)).Row 
    Range("B" & findrow + 1 & ":M" & findrow2 - 1).Select 
End Sub 

「比較」してシートを比較し、詳細な顧客情報を別のシートにコピーするにはどうすればよいですか？添付ファイルで

Sub Compare() 
    Dim w1 As Worksheet, w2 As Worksheet, w3 As Worksheet 
    Dim findrow1 As Long, findrow2 As Long 
    Dim range1 As Range, range2 As Range, c As Range 

    Set w1 = Worksheets("Raport") 
    Set w2 = Worksheets("Dane") 
    Set w3 = Worksheets("Produkt1") 

    findrow1 = w1.Range("B:B").Find("Produkt2", w1.Range("B1")).Row 
    findrow2 = w1.Range("B:B").Find("Laczna ilosc Produkt2", w1.Range("B" & findrow1)).Row 
    Set range1 = w1.Range("B" & findrow1 + 1 & ":M" & findrow2 - 1) 
    Set range2 = w2.Range("2:137") 

    If range1 = w2.range2 Then 
     range2.EntireRow.Copy w3.Cells(Rows.Count, 1).End(xlUp)(2) 
    End If 
End Sub 

最終結果（詳細な顧客情報は、単にマクロを使用せずにProdukt1とProdukt2シートにコピーされる）を持つファイルがあります。 - あなたは

range2.EntireRow.Copy 

で所望の範囲をコピーした後>https://uploadfiles.io/ttmck

Answer 1

次の行を貼り付けする必要があります。

Worksheets(1).Paste Destination:=Worksheets(1).Cells(Rows.Count, 1).End(xlUp)(2, 1) 

目的地でWorksheets(1)を交換してください。これによりコピーされたすべての行が宛先シート上の連続した行に配置されますが、最終的にはその範囲に約RemoveDuplicatesが必要になります。