Excel VBA根据条件从一个工作表复制到其他工作表特定单元格

Posted 2021-04-17

我试图从Sheet1复制，特定行在该行上特定单元格的状态为“DONE”，并且“DONE”之后的第二个条件是检查是否在同一行，另一个单元格也具有特定值。之后，复制在特定工作表上找到的行，检查目标是否找到重复项。

我已经管理到现在根据2个标准从Sheet1复制到另一个（旧学校用IF，我尝试使用自动过滤器，但我没有设法做到）但我很难防止重复复制到其他床单。

我尝试了所有的东西，根据带有Range的第一张纸进行价值检查，为每张纸写一个宏，这样就可以防止重复，没有任何效果，我对此感到困惑。

下面的代码的另一个问题是，在多次点击Update按钮后，它不会复制所有找到的行，而只复制找到的第一行，并且还在其间插入一些空行，我不明白其原因。

这是代码：

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

答案

我无法测试下面建议的代码，但我相信它可以做你想做的事情。

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