VBA find and select rows with specific month

Topic

New Reply

Hi,

I have a column with dates from the past 10 years. I want to create a macro with VBA that search for dates which have last month in it.

For example lets say that there are 10 dates that meet this requirment, the macro have to select these rows and copy them to another sheet.

So first the macro need to have the search specification: this month minus one. The day is not important only the month and year. Search for all dates that meet this month and year. Then select all these rows.

Can someone help me with this?

Reply | Quote

Replies

Mattie,

Welcome to the lounge as a poster. :cheers:

Do you want the last month for all years in the list or only the current year?

May the Forces of good computing be with you!

RG

PowerShell & VBA Rule!
Computer Specs

Reply | Quote

No it has to be only the last month of the current year!

Reply | Quote

Mattie,

The attached worksheet contains the macro below and also the dynamic range name necessary. The number of rows {3000} and columns {2} can be adjusted to fit your data list.

Dynamic range name: Transactions [noparse]=OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A$1:$A$3000),COUNTA(Sheet1!$A$1:$B$1))[/noparse]

Code:

Option Explicit

Sub SelectCopyPrevMonth()

'Defined Name Transactions: =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A$1:$A$3000),COUNTA(Sheet1!$A$1:$B$1))

    Application.ScreenUpdating = False     'Prevent screen flicker
    [A1].Select
    Selection.AutoFilter
    ActiveSheet.Range("Transactions").AutoFilter Field:=1, Criteria1:= _
        xlFilterLastMonth, Operator:=xlFilterDynamic
    Selection.CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    [A1].Select
    ActiveSheet.Paste
    [A1].Select                          'get rid of selection
    Sheets("Sheet1").Activate
    Application.CutCopyMode = False      'get rid of marque
    Selection.AutoFilter                 'turn off autofilter
    [A1].Select                          'get rid of selection
    
End Sub

Please note: This macro will work in Excel 2010 and maybe 2007 but needs more work to work in 2003 to calculate the previous month for the filter since 2003 does not have the xlFilterLastMonth constant defined. :cheers:

May the Forces of good computing be with you!

RG

PowerShell & VBA Rule!
Computer Specs

Reply | Quote

Mattie,

Here’s a version that will work in 2003 – 2010.

Code:

Sub SelectCopyPrevMonth2003()

   Dim iLastMonth   As Integer
   Dim iCurYear     As Integer
   Dim zLastDay     As String
   Dim zStartFltr   As String
   Dim zEndFltr     As String
   
   Application.ScreenUpdating = False
   
   iLastMonth = Month(Now()) - 1
   iCurYear = Year(Now())
   If iLastMonth = 0 Then
     iLastMonth = 12
     iCurYear = iCurYear - 1
   Else
     Select Case iLastMonth
     Case 4, 6, 9, 11
       zLastDay = "30"
     Case 2
       If (iCurYear Mod 4 = 0 And _
          iCurYear Mod 100  0) Or _
          iCurYear Mod 400 = 0 Then
         zLastDay = 29
       Else
         zLastDay = 28
       End If
     Case Else
       zLastDay = "31"
     End Select
   End If
   
   zStartFltr = ">=" & Format(iLastMonth) & "/1/" & Format(iCurYear)
   zEndFltr = "<=" & Format(iLastMonth) & "/" & zLastDay & "/" & Format(iCurYear)
    Range("Transactions").Select
    Selection.AutoFilter Field:=1, _
          Criteria1:=zStartFltr, Operator:=xlAnd, _
          Criteria2:=zEndFltr
          
    Selection.CurrentRegion.Select
    Selection.Copy
    Sheets("Sheet2").Select
    [A1].Select
    ActiveSheet.Paste
    [A1].Select                          'get rid of selection
    Sheets("Sheet1").Activate
    Application.CutCopyMode = False      'get rid of marque
    Selection.AutoFilter                 'turn off autofilter
    [A1].Select                          'get rid of selection
          
End Sub

:cheers:

May the Forces of good computing be with you!

RG

PowerShell & VBA Rule!
Computer Specs

Reply | Quote

RG, Thank you, I appreciate your help!

I already succeeded by myself with the following macro:

Code:

' Open overview and copy data into this excel file:

    Application.DisplayAlerts = False
    Sheet1.Activate
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Workbooks.Open Filename:= _
        "I:...........xls"
    ActiveWindow.SmallScroll Down:=-9
        Range("A1:AB2754").Sort Key1:=Range("Q1"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Cells.Select
    Range("Q2").Activate
    Selection.Copy
    Windows("bridge document.xls").Activate
    Sheet1.Activate
    Cells.Select
    ActiveSheet.Paste
    Columns("Q:Q").Select
    Selection.NumberFormat = "mm/dd/yyyy"
        Windows("Models.xls").Activate
    ActiveWorkbook.Close
    Application.DisplayAlerts = True

'Select and copy data of past month to sheet 2.
 
 
    Sheet2.Activate
    Rows("2:501").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A2").Select
  
    On Error GoTo ErrHandler
    
    Dim dStartDate As Date
    Dim dEndDate As Date
    
    'Collect Start & End Dates
    dStartDate = CDate(DateAdd("m", -1, Date))
    dEndDate = CDate(Now)
    
    
    'Find Dates Between Start Date & End Date and move to sheet 2
    Sheet1.Activate
    
    'Assume column Q contains the dates
    Application.Range("Q1").Select
    
    'Look at every row in column q until it finds an empty cell.
    Do Until ActiveCell.Value = vbNullString
    
    'Verify that the date is between the Start Date & End Date
    If ActiveCell.Value > dStartDate And ActiveCell.Value < dEndDate Then
    
    'If it is, copy the entire row
    ActiveCell.EntireRow.Copy
    
    'Activate sheet 2
    Sheet2.Activate
    
    'Find the first blank row on sheet 2
    Application.Range("A1").Select
    Do Until ActiveCell.Value = vbNullString
    ActiveCell.Offset(1, 0).Select
    Loop
    
    'Paste the row from sheet 1
    ActiveSheet.Paste
    
    'Return to sheet 1
    Sheet1.Activate
    End If
    
    'Move down one row
    ActiveCell.Offset(1, 0).Select
    Loop
    
    'Activate sheet 3
    Sheet3.Activate

Reply | Quote