Excel VBA Kopie von einem Blatt zu anderen Blättern spezifische Zellen basierend auf Kriterien

Question

Ich versuche, aus Sheet1, bestimmte Zeilen zu kopieren, wenn in dieser Zeile eine bestimmte Zelle den Status "DONE" ausgewählt hat zu sagen, und ein zweites Kriterium nach "DONE "ist zu prüfen, ob in derselben Zeile eine andere Zelle auch einen bestimmten Wert hat. Danach kopieren Sie die gefundenen Zeilen jeweils auf ein bestimmtes Blatt und überprüfen das Ziel, wenn Duplikate gefunden werden.

Ich habe es bis jetzt geschafft, von Sheet1 zu den anderen zu kopieren, basierend auf den 2 Kriterien (alte Schule mit IF, habe ich mit Autofilter versucht, aber ich habe es nicht geschafft), aber ich habe Schwierigkeiten, Duplikate zu verhindern auf die anderen Blätter kopiert werden.

Ich habe alles versucht, Wertüberprüfung basierend auf dem ersten Blatt mit Bereich, Schreiben eines Makros für jedes Blatt, so dass es Dubletten verhindert, hat nichts gearbeitet, und ich bin auf diesem fest.

Ein weiteres Problem mit unter Code ist, dass nach dem Drücken der Update-Taste mehrmals, es nicht alle gefundenen Zeilen dupliziert, sondern nur die erste gefunden, und fügt auch einige leere Zeilen dazwischen und ich verstehe nicht den Grund dafür. Hier

ist der 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

ich nicht den Code unten vorgeschlagen testen könnte, aber ich glaube, dass es das tut, was Sie es tun wollen.

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