隐藏单个行，仅将可见行复制并粘贴到新工作表中

Question

所有

我有一些我写的代码（绝对没有优化，所以请不要批评:)）

在循环中调用例程，该循环检查书中的特定表。选择工作表后，工作表的所有行都会与多个值进行比较，如果它们匹配或不匹配，则需要隐藏它们，我使用行（i）.hidden = True命令。

一切都基于H（i）和I（i）中的值，即月（H）和年（I）。因此，如果datediff比较为0，-1，-2或-3，则该行仍然可见。如果列C中有单词DUPLICATE或者Datediff比较是> 0然后该行被隐藏。处理完所有行后，会将其返回主程序，将VISIBLE行复制并粘贴到新工作表中。

大多数情况下，选择和隐藏例程似乎都有效，但我无法使复制/过去例程起作用。

这是我到目前为止的代码：

Public Function CheckDateToIncludeInPrintRNLH(CurRow As Integer, SheetName As String, LastRow2 As Integer) As Integer
 Dim ChkMonth As Long, ChkYear As Long, RenewYear As Long, RenewMonth As Long, OtherMonth As Long
    Dim OtherYear As Long, OtherDate As String
    Dim RenewDate As String, TodayDate As Date, TrgtDate As Date, TrgtMonth As String, TrgtYear As String, TrgtPt As String
    Dim include As Integer, Exclude As Integer, x As Integer, i As Integer
    Dim EndMonth As String, EndYear As String

    ActiveSheet.Range("A" & CurRow & ":Q" & CurRow).Select

' I found a case where the first row is not always grey, indicating the actual renewal date.
' This routine checks the first 10 lines (10 is just an arbitrary number, to find the first non-white
' cell and use that for EndMonth and EndYear.

    For i = 2 To LastRow2

        If EndMonth = "" Or EndMonth = " " Or EndYear = "" Or EndYear = " " Then
            If Range("H" & i).Interior.Color = vbWhite Then
                If i = LastRow2 Then
                    EndMonth = Sheets(SheetName).Range("H" & LastRow2)
                    EndYear = Sheets(SheetName).Range("I" & LastRow2)
                    'GoTo ChkAgain
                Else
                    EndMonth = Sheets(SheetName).Range("H" & i)
                    EndYear = Sheets(SheetName).Range("I" & i)
                End If
            Else
                EndMonth = Sheets(SheetName).Range("H" & i)
                EndYear = Sheets(SheetName).Range("I" & i)
                GoTo BreakIt
            End If
ChkAgain:
        End If
        Next i
BreakIt:

    TodayDate = Now()
    RenewMonth = EndMonth

    ' We print renewals 6 months ahead of time, so if it is July or later, the RenewYear should be the next year.

    If Month(TodayDate + 6) > 6 Then
        RenewYear = Year(TodayDate) + 1

    Else
        RenewYear = Year(TodayDate)

    End If

    'Build out Renewal Date as a string
    RenewDate = (RenewMonth & "/" & RenewYear)

    'Build out Other Date for comparison, as string
    OtherMonth = Sheets(SheetName).Range("H" & CurRow).Value
    OtherYear = Sheets(SheetName).Range("I" & CurRow).Value
    OtherDate = (OtherMonth & "/" & OtherYear)

    For i = 2 To LastRow2

        If DateDiff("m", RenewDate, OtherDate) > 0 Then
            include = False         'do not include
            Rows(i).Hidden = True   'Set row to hidden
            CheckDateToIncludeInPrintRNLH = include 'Set return value if needed
            GoTo GoNext  'EndFunc            ' End Function and return to calling sub

        End If

        TrgtDate = DateAdd("m", -3, RenewDate)
        TrgtMonth = Month(TrgtDate)
        TrgtYear = OtherYear
        TrgtPt = (TrgtMonth & "/" & TrgtYear)


        x = DateDiff("m", RenewDate, OtherDate)

' Now check if Duplicate or does not equal 0, -1, -2, or -3
' If Duplicate, hide row, if it does not equal one of the above, hide it

        Select Case ActiveSheet.Range("C" & CurRow)
            Case "DUPLICATE"
                include = False
                Rows(i).Hidden = True
'                CheckDateToIncludeInPrintRNLH = include
                GoTo EndFunc
            Case Else
                Select Case x
                    Case "0", "-1", "-2", "-3"
                        include = True
                        Rows(i).Hidden = False
                    Case Else
                        include = False
                        Rows(i).Hidden = True
                End Select
        End Select
GoNext:
    CurRow = CurRow + 1
    Next i

    CheckDateToIncludeInPrintRNLH = include

EndFunc:

End Function

复制/粘贴的代码是：

ws.Range("A" & CurrentRow & ":Q" & CurrentRow).SpecialCells(xlCellTypeVisible).Copy _
                    Worksheets("Reps No Longer Here").Range("A" & pasterow)

我非常感谢您提供的任何帮助/帮助!!!