Data transfer based on date

[menajaro]

Hello everyone
I have a master workbook with a sheet that has around 40 columns of data and I have this code that Transfer data from column A to column Q
to summary sheet & Other payments sheet Depending on the dates of next month in column P... the code is working well as per the range of data to be transferred from column A to column Q.... The problem right now is that the code Transfer all columns containing data from column R to the last column.
How can I transfer data as per the required range only in both summary sheet & Other payments sheet
For testing, please record any data in the column R Then run the code to see what I mean
How can I modify or add code to proceed with this Topic?
Please have a look at the file, thank you for your cooperation in advance

[HansV]

Here is a modified version. I have indicated the two lines that have changed:

Code: Select all

Sub test()
    Dim wshM As Worksheet
    Dim wshE As Worksheet
    Dim wshO As Worksheet
    Dim LastR As Range
    Dim rngR As Range
    Dim m As Long
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Set wshM = Worksheets("master workbook")
    m = wshM.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set wshE = Worksheets("Summary")
    wshE.Cells.Delete
    wshM.Range("A1:Q7").Copy Destination:=wshE.Range("A1")
    With wshM
        .Range("Y2").Formula = "=OR(ISTEXT(P7),EOMONTH(P7,0)=EOMONTH(TODAY(),1))"
        ' **** Changed ****
        With .Range("A7:Q" & m)
            .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=wshM.Range("Y1:Y2")
            .Offset(2).Copy wshE.Range("A8")
            .Offset(2).Delete Shift:=xlShiftUp
        End With
        If .FilterMode Then .ShowAllData
        .Range("Y2").Clear
    End With
    On Error Resume Next
    Set wshO = Worksheets("Other payments")
    On Error GoTo 0
    If wshO Is Nothing Then
        Set wshO = Worksheets.Add(After:=wshE)
        wshO.Name = "Other payments"
        wshM.Range("A1:Q7").Copy Destination:=wshO.Range("A1")
        Set LastR = wshO.Range("A8")
    Else
        Set LastR = wshO.Range("A" & wshO.Rows.Count).End(xlUp).Offset(1)
    End If
    With wshE
        ' **** Changed ****
        Set rngR = .Range("A8:Q" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
        rngR.Sort Key1:=.Range("P8"), Header:=xlNo
        On Error Resume Next
       .Columns(16).SpecialCells(xlCellTypeConstants, xlNumbers).Value = "Finished"
        On Error GoTo 0
        If Application.CountA(.Columns(1)) > 1 Then
            rngR.Copy Destination:=LastR
        End If
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
End Sub

[menajaro]

That's wonderful .. I am so grateful for you Mr. Hans
I have tested these wonderful modifications, but it does not delete or transfer the starts of any month.
Otherwise, things are okay ...So how I can fix that?

[HansV]

Here is a new version:

Code: Select all

Sub test()
    Dim wshM As Worksheet
    Dim wshE As Worksheet
    Dim wshO As Worksheet
    Dim LastR As Range
    Dim rngR As Range
    Dim m As Long
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Set wshM = Worksheets("master workbook")
    m = wshM.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set wshE = Worksheets("Summary")
    wshE.Cells.Delete
    wshM.Range("A1:Q7").Copy Destination:=wshE.Range("A1")
    With wshM
        .Range("Y2").Formula = "=OR(ISTEXT(P8),EOMONTH(P8,0)=EOMONTH(TODAY(),1))"
        With .Range("A7:Q" & m)
            .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=wshM.Range("Y1:Y2")
            .Offset(1).Copy wshE.Range("A8")
            .Offset(1).Delete Shift:=xlShiftUp
        End With
        If .FilterMode Then .ShowAllData
        .Range("Y2").Clear
    End With
    On Error Resume Next
    Set wshO = Worksheets("Other payments")
    On Error GoTo 0
    If wshO Is Nothing Then
        Set wshO = Worksheets.Add(After:=wshE)
        wshO.Name = "Other payments"
        wshM.Range("A1:Q7").Copy Destination:=wshO.Range("A1")
        Set LastR = wshO.Range("A8")
    Else
        Set LastR = wshO.Range("A" & wshO.Rows.Count).End(xlUp).Offset(1)
    End If
    With wshE
        Set rngR = .Range("A8:Q" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
        rngR.Sort Key1:=.Range("P8"), Header:=xlNo
        On Error Resume Next
       .Columns(16).SpecialCells(xlCellTypeConstants, xlNumbers).Value = "Finished"
        On Error GoTo 0
        If Application.CountA(.Columns(1)) > 1 Then
            rngR.Copy Destination:=LastR
        End If
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
End Sub

[menajaro]

Thank you very much Mr. Hans for great help
That's perfect and awesome now, The last point now for me
I need to Add some formats like font type, size, Autofit the Columns widths in both summary sheet & Other payments sheet
Thanks a lot for your great support all the time

[HansV]

To autofit the columns, add the following lines above Application.Calculation = xlCalculationAutomatic:

Code: Select all

    wshE.Range("A1:Q1").EntireColumn.AutoFit
    wshO.Range("A1:Q1").EntireColumn.AutoFit

I'll leave it to you to set font properties.

[menajaro]

Thanks a lot Mr. Hans for all the great help you offered
Kind Regards