Need VBA to automatically copy paste rows based on dates of current month.

[pk970]

I would like to develop a VBA code which copies rows from sheet 1 based on date column & paste it in another sheet. It shall only copy rows whose date falls in current month. I have 2 requirements. My excel workbook has over 15 tabs and its a heavy file.

1) I have a sheet lets name it sheet 2, it consists of a data column which consists much older dates. I need first to delete rows which has dates of current month i.e. if the date is of April 2024 then I need to delete all rows.

2) I have another sheet which consists of a date column and date range is very vast i.e. it has date which goes back to the year 2000. I need to copy only specific rows which has falls in current month i.e. I need to copy rows whose date is April 2024 and paste those same rows in sheet 2.

I am very new to VBA and I got this situation in my project. A full code would be really helpful.
Thank You in advance.

 

[Cubist]

Try on a copy.

Option Explicit

Sub CopyPasteDate()
    Dim sourceSheet As Worksheet, destSheet As Worksheet
    Dim i As Long
    Dim lastRow As Long, destLastRow As Long
    Dim currentMonthStart As Date, currentMonthEnd As Date
    Dim copyRange As Range
   
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
    Set destSheet = ThisWorkbook.Worksheets("Sheet2")
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
   
    ' Calculate the first and last date of the current month
    currentMonthStart = DateSerial(Year(Now), Month(Now), 1)
    currentMonthEnd = DateSerial(Year(Now), Month(Now) + 1, 0)
   
    ' Clear existing data in destination sheet
    destSheet.Cells.Clear
   
    For i = 2 To lastRow
        If IsDate(sourceSheet.Cells(i, 1).Value) Then ' Check if the value is a date
            If sourceSheet.Cells(i, 1).Value >= currentMonthStart And sourceSheet.Cells(i, 1).Value <= currentMonthEnd Then
                ' Copy the entire row to copyRange
                If copyRange Is Nothing Then
                    Set copyRange = sourceSheet.Rows(i)
                Else
                    Set copyRange = Union(copyRange, sourceSheet.Rows(i))
                End If
            End If
        End If
    Next i
   
    ' Paste the copied range to the destination sheet
    If Not copyRange Is Nothing Then
        copyRange.Copy destSheet.Cells(2, 1)
    End If
End Sub

 

[mumps]

You haven't given us the actual worksheet names or the columns in which the dates are found so the macro below will have to be changed to reflect the actual sheet names and column letters and numbers. Change the sheet names (in red) to match your actual sheet names, the column letters (in blue) to match your actual column letters and the column numbers (in green) to match your column numbers. Also, the macro assumes that you have headers in row 1 of each sheet and your data starts in row 2. If this doesn't work, then use the XL2BB add-in (icon in the menu) to attach a screenshots (not pictures) of your two sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    With srcWS
        .Range("A1").AutoFilter Field:=1, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("A1").AutoFilter
    End With
    With desWS
        .Range("A1").AutoFilter Field:=1, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).Copy srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Offset(1)
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[pk970]

You haven't given us the actual worksheet names or the columns in which the dates are found so the macro below will have to be changed to reflect the actual sheet names and column letters and numbers. Change the sheet names (in red) to match your actual sheet names, the column letters (in blue) to match your actual column letters and the column numbers (in green) to match your column numbers. Also, the macro assumes that you have headers in row 1 of each sheet and your data starts in row 2. If this doesn't work, then use the XL2BB add-in (icon in the menu) to attach a screenshots (not pictures) of your two sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    With srcWS
        .Range("A1").AutoFilter Field:=1, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("A1").AutoFilter
    End With
    With desWS
        .Range("A1").AutoFilter Field:=1, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).Copy srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Offset(1)
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Hello,

Thank You for the solution. I cannot share the screenshot of the actual data as it is very sensitive client data. My system doesn't allow to take a screenshot. Actual column has over 60 columns and over 1000 rows.
I have tried to create 2 sheets with few columns but similar problem statement whose screenshot I will try to attach here.
Actual problem statement is that the excel work book gets updated daily and new rows gets added daily as per transactions and billing in sheet 1. Now sheet 2 is the output sheet which has similar columns as sheet1 and it needs to get updated as per sheet1.
I tried doing Vlookup to find the non matching rows and adding them from Sheet1 to Sheet2 based on NA value. But the bigger problem is the sheet1 has too many NA values based on historic data i.e. previous year data which client does not wants to touch and they want only rows based on present month to be updated hence I needed a solution.
Hope the screenshot helps.
I have never used VBA in my life and suddenly I have been assigned this project and there is no one to help with VBA either so I am highly dependent on internet to get code, understand it, change the parameters and run it on my actual sheet.

Any help is highly appreciated.

 

[mumps]

Your attachments are actually pictures, not screen shots and it is hard to work with pictures. I have simply changed the macro to reflect the dates being in column D. If the macro below doesn't work, you can attach screen shots or upload your file by following the instructions in Post #3. If your data is sensitive, you could replace it with generic data. I would only need a dozen or so rows of data in each sheet. It is important to include data for all the columns and that your data is organized in exactly the same way as in your actual file.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    With srcWS
        .Range("D1").AutoFilter Field:=4, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("D1").AutoFilter
    End With
    With desWS
        .Range("D1").AutoFilter Field:=4, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).Copy srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Offset(1)
        .Range("D1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[pk970]

Your attachments are actually pictures, not screen shots and it is hard to work with pictures. I have simply changed the macro to reflect the dates being in column D. If the macro below doesn't work, you can attach screen shots or upload your file by following the instructions in Post #3. If your data is sensitive, you could replace it with generic data. I would only need a dozen or so rows of data in each sheet. It is important to include data for all the columns and that your data is organized in exactly the same way as in your actual file.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    With srcWS
        .Range("D1").AutoFilter Field:=4, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("D1").AutoFilter
    End With
    With desWS
        .Range("D1").AutoFilter Field:=4, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).Copy srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Offset(1)
        .Range("D1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Sure. I will try the code the code and I will let you know.
But thanks a lot.

 

[pk970]

Sure. I will try the code the code and I will let you know.
But thanks a lot.

Your attachments are actually pictures, not screen shots and it is hard to work with pictures. I have simply changed the macro to reflect the dates being in column D. If the macro below doesn't work, you can attach screen shots or upload your file by following the instructions in Post #3. If your data is sensitive, you could replace it with generic data. I would only need a dozen or so rows of data in each sheet. It is important to include data for all the columns and that your data is organized in exactly the same way as in your actual file.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    With srcWS
        .Range("D1").AutoFilter Field:=4, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("D1").AutoFilter
    End With
    With desWS
        .Range("D1").AutoFilter Field:=4, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
        .AutoFilter.Range.Offset(1).Copy srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Offset(1)
        .Range("D1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

If possible can we connect over email or other place. I don't know about this site policy so asking.

 

[mumps]

Forum members are asked to keep all communication in the Forum so that all members have the opportunity to participate.

 

[pk970]

Forum members are asked to keep all communication in the Forum so that all members have the opportunity to participate.

I have posted another question too.

Automating copying of columns within same sheet in excel using VBA.

Hi All, I am very new in VBA and I have came across a situation in my project where I need to use VBA to copy columns within the sheet and then replace the same columns with other data. I will try to explain the situation as much as I can in description. I have an excel workbook which consists...

www.mrexcel.com

Maybe you can also help me with the same.

 

[mumps]

Is the macro I suggested in Post #5 working for you now?