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.
Transfer two ranges of columns Depending on date
-
- StarLounger
- Posts: 68
- Joined: 03 Aug 2020, 05:23
Transfer two ranges of columns Depending on date
You do not have the required permissions to view the files attached to this post.
-
- 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
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
Hans
-
- StarLounger
- Posts: 68
- Joined: 03 Aug 2020, 05:23
Re: Transfer two ranges of columns Depending on date
Thanks a lot Mr. Hans .. It is working exactly as I need