Excel VBAのコピーをシートから他のシートにコピーする

Question

Sheet1から特定の行をコピーしようとしていますが、その行にある特定のセルのステータスが「DONE」で、「DONE同じ行で別のセルにも特定の値があるかどうかをチェックすることです。その後、特定のシートに見つかった行をコピーし、重複が見つかった場合は宛先をチェックします。

これまで2つの基準（私はオートフィルタで試してみましたが、私はそれをやってみましたが）で2つの基準に基づいてSheet1から別のコピーに管理していましたが、他のシートにコピーされます。

私はRangeを使って最初のシートに基づいて値をチェックし、各シートのマクロを書き込んで重複を防止しました。何も働かず、私はこれに固執しています。

以下のコードのもう1つの問題は、[更新]ボタンを複数回押すと、見つかったすべての行は複製されず、最初のものだけが見つかり、その間に空の行が挿入され、それのために。ここで

はコードです：

Private Sub CommandButton1_Click() 
Dim LastRow As Long 
Dim i As Long, j As Long, k As Long, j1 As Long, k1 As Long, j_last As Long, 
k_last As Long 
Dim a As Long, b As Long 
Dim ActiveCell As String 

With Worksheets("PDI details") 
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
End With 

With Worksheets("Demo ATMC") 
    j = .Cells(.Rows.Count, "A").End(xlUp).Row + 2 
End With 

With Worksheets("Demo ATMC Courtesy") 
    k = .Cells(.Rows.Count, "A").End(xlUp).Row + 2 
End With 

With Worksheets("Demo SHJ") 
    j1 = .Cells(.Rows.Count, "A").End(xlUp).Row 
    k1 = .Cells(.Rows.Count, "A").End(xlUp).Row 
End With 

With Worksheets("Demo AD") 
    a = .Cells(.Rows.Count, "A").End(xlUp).Row 
    b = .Cells(.Rows.Count, "A").End(xlUp).Row 
End With 

MsgBox (j) 
For i = 5 To LastRow 
    With Worksheets("PDI details") 
     If .Cells(i, 20).Value <> "" Then 

      If .Cells(i, 20).Value = "DONE" Then 
       If .Cells(i, 11).Value = "ATMC DEMO" Then 

        If Not .Cells(i, 7) = Worksheets("Demo ATMC").Range("D4") Then 
         Worksheets("Demo ATMC").Range("A" & j) = Worksheets("PDI details").Range("A" & i).Value 
         Worksheets("Demo ATMC").Range("B" & j) = Worksheets("PDI details").Range("E" & i).Value 
         Worksheets("Demo ATMC").Range("C" & j) = Worksheets("PDI details").Range("F" & i).Value 
         Worksheets("Demo ATMC").Range("D" & j) = Worksheets("PDI details").Range("G" & i).Value 
         Worksheets("Demo ATMC").Range("F" & j) = Worksheets("PDI details").Range("H" & i).Value 
         Worksheets("Demo ATMC").Range("G" & j) = Worksheets("PDI details").Range("I" & i).Value 

        End If 
       End If 
       If .Cells(i, 11).Value = "ATMC COURTESY" Then 
        If Not .Cells(i, 7) = Worksheets("Demo ATMC Courtesy").Range("D4") 
        Then 
         Worksheets("Demo ATMC Courtesy").Range("A" & k) = Worksheets("PDI details").Range("A" & i).Value 
         Worksheets("Demo ATMC Courtesy").Range("B" & k) = Worksheets("PDI details").Range("E" & i).Value 
         Worksheets("Demo ATMC Courtesy").Range("C" & k) = Worksheets("PDI details").Range("F" & i).Value 
         Worksheets("Demo ATMC Courtesy").Range("D" & k) = Worksheets("PDI details").Range("G" & i).Value 
         Worksheets("Demo ATMC Courtesy").Range("F" & k) = Worksheets("PDI details").Range("H" & i).Value 
         Worksheets("Demo ATMC Courtesy").Range("G" & k) = Worksheets("PDI details").Range("I" & i).Value 

         k = k + 1 
        End If 
       End If 
      End If 
     End If 
    End With 
Next i 
End Sub 

Answer 1

私はコードをテストすることができませんでした以下の提案が、私はそれはあなたがそれを行うことを希望するものをないと信じています。

Option Explicit 

Private Sub CommandButton1_Click() 
    ' 23 Dec 2017 

    Dim WsPdi As Worksheet 
    Dim WsAtmc As Worksheet, WsCourtesy As Worksheet 
    Dim R As Long, Rl As Long    ' row/lastrow "PDI details" 

    Set WsPdi = Worksheets("PDI Detail") 
    Set WsAtmc = Worksheets("Demo ATMC") 
    Set WsCourtesy = Worksheets("Demo ATMC Courtesy") 

    Application.ScreenUpdating = False 
    With WsPdi 
     Rl = .Cells(.Rows.Count, "A").End(xlUp).Row 
     For R = 5 To Rl 
      If .Cells(R, 20).Value = "DONE" Then 
       Select Case .Cells(R, 11).Value 
        Case "ATMC DEMO" 
         TransferData WsPdi, WsAtmc, R 
        Case "ATMC COURTESY" 
         TransferData WsPdi, WsCourtesy, R 
       End Select 
      End If 
     Next R 
    End With 
    Application.ScreenUpdating = True 
End Sub 

Private Sub TransferData(WsSource As Worksheet, _ 
         WsDest As Worksheet, _ 
         R As Long) 
    ' 23 Dec 2017 

    Dim Csource() As String 
    Dim Rn As Long       ' next empty row in WsDest 
    Dim C As Long 

    Csource = Split(",A,E,F,G,,H,R", ",") 
    With WsDest 
     If WsSource.Cells(R, 7).Value <> .Cells(4, "D").Value Then 
      Rn = .Cells(.LastRow, "A").End(xlUp).Row + 1 
      For C = 1 To 7      ' columns A to G 
       If C <> 5 Then 
        .Cells(Rn, C).Value = WsSource.Cells(R, Csource(C)).Value 
       End If 
      Next C 
     End If 
    End With 
End Sub