Transfer two ranges of columns Depending on date

luis gaspper
StarLounger
Posts: 68
Joined: 03 Aug 2020, 05:23

Transfer two ranges of columns Depending on date

Post by luis gaspper »

Dear experts,
Just a small change required if possible
I have a Main workbook with a sheet that has around 70 columns of data and I have this code that Transfer data from column A to column Q
to unacceptable sheet & Medical Committee 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
But I need to transfer another range from AE to AN ... I tried to adjust some lines, but to no avail
I have highlighted the lines that need to be adjusted ... Is there a way to edit this? Please have a look at the file ...Thank you.
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Transfer two ranges of columns Depending on date

Post by HansV »

Try this version:

Code: Select all

Sub TransferTwoRangesBasedOnDate()
    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(" Main workbook")
    m = wshM.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set wshE = Worksheets("appropriate")
    wshE.Cells.Delete
    wshM.Range("A7:Q7").Copy Destination:=wshE.Range("A7")
    wshM.Range("AE7:AN7").Copy Destination:=wshE.Range("R7")
    With wshM
        .Range("Y2").Formula = "=OR(ISTEXT(P8),EOMONTH(P8,0)=EOMONTH(TODAY(),1))"
        With .Range("A7:BR" & m)
            .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wshM.Range("Y1:Y2"), _
                CopyToRange:=wshE.Range("A7:AA7")
            .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=wshM.Range("Y1:Y2")
            .Offset(1).Delete Shift:=xlShiftUp
        End With
        If .FilterMode Then .ShowAllData
        .Range("Y2").Clear
    End With
    On Error Resume Next
    Set wshO = Worksheets("Medical Committee")
    On Error GoTo 0
    If wshO Is Nothing Then
        Set wshO = Worksheets.Add(After:=wshE)
        wshO.Name = "Medical Committee"
        wshM.Range("A7:Q7").Copy Destination:=wshO.Range("A7")
        wshM.Range("AE7:AN7").Copy Destination:=wshO.Range("R7")
        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:AA" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
        rngR.Sort Key1:=.Range("P8"), Header:=xlNo
        On Error Resume Next
       .Columns(16).SpecialCells(xlCellTypeConstants, xlNumbers).Value = "Medically unfit"
        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
Best wishes,
Hans

luis gaspper
StarLounger
Posts: 68
Joined: 03 Aug 2020, 05:23

Re: Transfer two ranges of columns Depending on date

Post by luis gaspper »

Thanks a lot Mr. Hans .. It is working exactly as I need