I have an excel document where I currently have a macro which copies two specific columns for each row from Sheet-1, and then paste it into Sheet-2.

I would like it to continue to copy and paste those two columns, but only if the specific row's date is greater than today's date 6 months. The date should not be copied, but only to decide if the row should be copied and pasted into Sheet-2.

To specify the above: I have a sheet called "Banks" (Sheet-1) whereof only the ISIN-code and Common name is copied into another sheet called "New Banks" (Sheet-2). In the sheet "Banks" (Sheet-1) the company's call date is also stated in column "G", which I would like to be the determine-factor (if call date is not within 6 months) of whether the row should be copied and pasted - or just continue to the next row.

To sum up, I would just like to add an argument to my current code. But I cant figure it out. I hope someone can help me.

I have the following code so far:

Sub Copydata()

Application.ScreenUpdating = False
    
Dim Ws, wsBank, As Worksheet
Dim LastRow As Long
Set wsBank = Sheets("New Banks")
wsBank.Range("a3:b1000").ClearContents

'Banks
Set Ws = Sheets("Banks")
LastRow = Ws.cells(1000, 1).End(xlUp).Row
If Ws.cells(LastRow, 1) = "" Then
Else

Ws.Range("B2:C" & LastRow).Copy
wsBank.Range("A" & 3).PasteSpecial Paste:=xlPasteValues
End If

End Sub

And I would like an argument like:

If Sheets("Banks").Range("G2") > Today 6 months then Copy and paste If not then next row

CodePudding user response：

Copy Row Based on Date Offset

Option Explicit

Private Enum sCols
    Blank = 1
    ISIN = 2
    Common = 3
    ColDate = 7 ' Date would mess up the 'Date' in 'DateAdd'
End Enum

Private Enum dCols
    ISIN = 1
    Common = 2
End Enum

Sub Copydata()

    ' Define constants.

    Const SRC_NAME As String = "Banks"
    Const DST_NAME As String = "New Banks"
    Const DST_FIRST_CELL As String = "A3"
    Const DST_COLUMNS_COUNT As Long = 2 ' tied to the 'dCols' enum
    Const MONTHS_OFFSET As Long = 6

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

    ' Write the values from the source range to an array.

    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    Dim Data() As Variant
    With sws.UsedRange
        Data = .Resize(.Rows.Count - 1).Offset(1).Value
    End With
    
    ' Calculate today's date 'MONTHS_OFFSET' months later.

    Dim LastDate As Date: LastDate = DateAdd("m", MONTHS_OFFSET, Date)

    ' Write the matching values to the top-left of the array.

    Dim sr As Long, dr As Long, dc As Long

    For sr = 1 To UBound(Data, 1)
        If Len(CStr(Data(sr, sCols.Blank))) > 0 Then
            If IsDate(Data(sr, sCols.ColDate)) Then
                If Data(sr, sCols.ColDate) < LastDate Then
                    dr = dr   1
                    Data(dr, dCols.ISIN) = Data(sr, sCols.ISIN)
                    Data(dr, dCols.Common) = Data(sr, sCols.Common)
                End If
            End If
        End If
    Next sr

    If dr = 0 Then
        MsgBox "No dates found.", vbExclamation
        Exit Sub
    End If

    ' Write the top-left values from the array to the destination range.

    ' Reference the destination range.
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
    Dim drg As Range: Set drg = dfCell.Resize(dr, DST_COLUMNS_COUNT)

    ' Write.
    drg.Value = Data
    ' Clear below.
    drg.Resize(dws.Rows.Count - drg.Row - dr   1).Offset(dr).ClearContents

    ' Inform.

    MsgBox "New banks updated.", vbInformation

End Sub