1

I have an Excel document where VBA code copies two columns for each row from Sheet-1 into Sheet-2.

I would like to copy those two columns only if the specific row's date is greater than today's date + 6 months. The date should not be copied into Sheet-2.

To specify the above:
I have a sheet called "Banks" (Sheet-1). 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". I would like this to be the determining factor (if call date is not within 6 months) of whether the row should be copied.

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

I would like:

If Sheets("Banks").Range("G2") > Today + 6 months then
Copy and paste
If not then next row
Improve this question
3
  • Try dateadd("M", 6, date) Commented Nov 25, 2022 at 14:19
  • First off, don't use Application.ScreenUpdating = False without True at the end. Secondly, where's your loop to go through the rows? Thirdly: are you sure your rows won't ever exceed 1000? Just thinking about making it flexible here. Commented Nov 25, 2022 at 14:56
  • It's actually only a snapshot of a longer code why Application.ScreenUpdating = True appears in the end of the code. Ain't that okay? I don't have any loop - how do you suggest that I apply that to the code? And yes, it won't exceed 1000 rows, but thanks anyway! Commented Nov 29, 2022 at 12:06

1 Answer 1

Reset to default
1

Copy Row Based on Date Offset

enter image description here

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
Improve this answer
Sign up to request clarification or add additional context in comments.

1 Comment

Sorry, I don't understand what you're asking. Could you share some more detail?

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.