Kopieren von Zellen aus einer bestimmten Spalte in ein anderes Arbeitsblatt basierend auf Kriterien

Question

Ich habe zwei Arbeitsblätter, "Signed" und "April". Ich möchte die Spalte "Y" von "Signed" basierend auf bestimmten Kriterien in die Spalte "A" von "April" kopieren, beginnend mit der nächsten verfügbaren/leeren Zeile. (so richtig unter den vorhandenen Daten). Meine Kriterien für Spalte Y ist, dass Spalte L = Monat der Zelle "D2" von "April" UND das Jahr der Zelle "D2" von "April" ... (so jetzt D2 ist 30.04.2017). Dann kopiere diese Zelle in die nächste verfügbare Zeile von Spalte A von "April" und füge weiter hinzu.

Ich habe mehrere verschiedene Dinge versucht, aber bin einfach nicht in der Lage, es zu bekommen..eine Idee, wie ich das erreichen kann?

Mein Code ist unten:

Set sourceSht = ThisWorkbook.Worksheets("Signed") 
Set myRange = sourceSht.Range("Y1", Range("Y" & Rows.Count).End(xlUp)) 
Set ws2 = Sheets(NewSheet) 
DestRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 



For Each rw In myRange.Rows 
If rw.Cells(12).Value = "Month(Sheets(ws2).Range("D2"))" Then 
myRange.Value.Copy Destinations:=Sheets(ws2).Range("A" & DestRow) 

End If 

Answer 1

So etwas sollte für Sie arbeiten:

Sub tgr() 

    Dim wb As Workbook 
    Dim wsData As Worksheet 
    Dim wsDest As Worksheet 
    Dim aData As Variant 
    Dim aResults() As Variant 
    Dim dtCheck As Date 
    Dim lCount As Long 
    Dim lResultIndex As Long 
    Dim i As Long 

    Set wb = ActiveWorkbook 
    Set wsData = wb.Sheets("Signed")  'This is your source sheet 
    Set wsDest = wb.Sheets("April")   'This is your destination sheet 
    dtCheck = wsDest.Range("D2").Value2  'This is the date you want to compare against 

    With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row) 
     lCount = WorksheetFunction.CountIfs(.Resize(, 1), ">=" & DateSerial(Year(dtCheck), Month(dtCheck), 1), .Resize(, 1), "<" & DateSerial(Year(dtCheck), Month(dtCheck) + 1, 1)) 
     If lCount = 0 Then 
      MsgBox "No matches found for [" & Format(dtCheck, "mmmm yyyy") & "] in column L of " & wsData.Name & Chr(10) & "Exiting Macro" 
      Exit Sub 
     Else 
      ReDim aResults(1 To lCount, 1 To 1) 
      aData = .Value 
     End If 
    End With 

    For i = 1 To UBound(aData, 1) 
     If IsDate(aData(i, 1)) Then 
      If Year(aData(i, 1)) = Year(dtCheck) And Month(aData(i, 1)) = Month(dtCheck) Then 
       lResultIndex = lResultIndex + 1 
       aResults(lResultIndex, 1) = aData(i, UBound(aData, 2)) 
      End If 
     End If 
    Next i 

    wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lCount).Value = aResults 

End Sub 

Alternative Methode Autofilter verwenden, anstatt über ein Array von Iterieren:

Sub tgrFilter() 

    Dim wb As Workbook 
    Dim wsData As Worksheet 
    Dim wsDest As Worksheet 
    Dim dtCheck As Date 

    Set wb = ActiveWorkbook 
    Set wsData = wb.Sheets("Signed")  'This is your source sheet 
    Set wsDest = wb.Sheets("April")   'This is your destination sheet 
    dtCheck = wsDest.Range("D2").Value2  'This is the date you want to compare against 

    With wsData.Range("L1:Y" & wsData.Cells(wsData.Rows.Count, "L").End(xlUp).Row) 
     .AutoFilter 1, , xlFilterValues, Array(1, Format(WorksheetFunction.EoMonth(dtCheck, 0), "m/d/yyyy")) 
     Intersect(.Cells, .Parent.Columns("Y")).Offset(1).Copy wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1) 
     .AutoFilter 
    End With 

End Sub 

Answer 2

Hier ein generisches Skript, das Sie leicht modifizieren können, um fast ALLE Kriterien nach Bedarf zu behandeln.

Sub Copy_If_Criteria_Met() 
    Dim xRg As Range 
    Dim xCell As Range 
    Dim I As Long 
    Dim J As Long 
    I = Worksheets("Sheet1").UsedRange.Rows.Count 
    J = Worksheets("Sheet2").UsedRange.Rows.Count 
    If J = 1 Then 
     If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0 
    End If 
    Set xRg = Worksheets("Sheet1").Range("A1:A" & I) 
    On Error Resume Next 
    Application.ScreenUpdating = False 
    For Each xCell In xRg 
     If CStr(xCell.Value) = "X" Then 
      xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1) 
      xCell.EntireRow.Delete 
      J = J + 1 
     End If 
    Next 
    Application.ScreenUpdating = True 
End Sub