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