Excel VBA根据条件从一张纸复制到另一张纸的特定单元格

Question

I am trying to copy from Sheet1, specific rows when on that row a specific cell has status "DONE" selected to say, and a second criteria after "DONE" is to check if on the same row, another cell has also a specific value. After that, copy the rows found each on specific sheet, checking destination if duplicates are found.

I have managed until now to copy from Sheet1 to the other based on the 2 criteria (old school with IF, I tried with autofilter but I didn't manage to do it) but I am having a hard time preventing duplicates to be copied to the other sheets.

I tried everything, value checking based on first sheet with Range, writing a macro for each sheet so it prevents duplicates, nothing worked and i am stuck on this.

Another problem with below code is that after hitting Update button multiple times, it doesn't duplicate all found rows, but only the first one found, and also inserts some empty rows in between and I don't understand the reason for that.

Here is the code:

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

I couldn't test the code suggested below but I believe that it does what you wish it to do.

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