Question

我有两个工作表，“签名”和“四月”。我想根据某些标准将“Yigned”中的列“Y”从下一个可用/空白行开始复制到“April”的“A”列中。（就在现有数据下）。我对Y列的标准是，如果列L =来自“4月”的单元格“D2”的月份和来自“ApriL”的单元格“D2”的年份...（所以现在D2是4/30/2017）。然后将该单元格复制到“四月”的Col A的下一个可用行中并继续添加。

我一直在尝试几种不同的东西但是却无法得到它......我对如何实现这一点有所了解？

我的代码如下：

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

这样的事情对你有用：

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

使用AutoFilter而不是迭代数组的替代方法：

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

这是一个通用脚本，您可以根据需要轻松修改以处理几乎任何条件。

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

根据条件

2 个答案: