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

Question

我正在尝试从Sheet1复制特定行，当该行上的某个特定单元格的状态选择为“ DONE”时要说，而“ DONE”之后的第二个条件是检查同一行上是否另一个单元格也具有特定值。 之后，复制在特定工作表上找到的每行，检查目标是否找到重复项。

到目前为止，我已经设法根据2个条件从Sheet1复制到另一个（使用IF的老派，我尝试使用自动过滤器，但是我没有设法做到），但是我很难阻止重复项被复制到其他的床单。

我尝试了一切，使用Range进行了基于第一张纸的价值检查，为每张纸写了一个宏，以防止重复，没有任何效果，我被卡在了这上面。

下面的代码的另一个问题是，在多次单击“更新”按钮后，它不会复制所有找到的行，而只会复制找到的第一行，并且还会在两者之间插入一些空行，我不知道这样做的原因。

这是代码：

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