VBA code to extract text on criteria basis

There are few more requirements in addition to the below code. I want code to perform following task at the end of the above code.

Requirements are

1) I want to extract the data in column "D" of sheet "Process Data" in same way. Please refer attachment. I have marked the required result in Yellow color in Sheet "Process data". The Data in Column D of sheet "Process Data" to extracted in Column E,F,G and H

2). Column "S" in Sheet "Process Data". If any cell in Column "S" Contains string starting with "Under Construction" then corresponding cell in Column "Y" will be Blank in originathat text in particular cell should go to Column "Y" in sheet "Process Data". I have marked the example in Blue color.

Cell "S25" Contains "Under Construction (New Property)". Hence the same text text should come in Cell "Y25"

Cell "S29" Contains "Under Construction (in six months)". Hence the same text text should come in Cell "Y29"

3) I want 3 New column Named as "Property Type", "Transaction" and “Proper Location” next to Column "AD" i.e. "AE" as "Property Type" and "AF" as "Transaction" and "AG" as "Proper Location" in Sheet "Process Data".
Column "AD" contains URL which contains type of Transaction, property type as well as exact location
(A) Any data Start with” -Commercial- or -Industrial- or -Multistorey- or -Warehouse- or Residential- or any other words (so you give me a option to add additional keyword also)” and ends before -FOR- is a Property type.
For example in Cell “AD2”, “Multistorey-Apartment” is Property type
For example in Cell “AD3”, “Commercial-Office-Space” is Property type
For example in Cell “AD7”, “Industrial-Building” is Property type
For example in Cell “AD10”, “Office-in-IT-Park-SEZ” is Property type
For example in Cell “AD14”, “Warehouse-Godown” is Property type
Hence needed result as mentioned below
in Cell “AE2” need text as “Multistorey-Apartment”
in Cell “AE3”, “Commercial-Office-Space”
in Cell “AE7”, “Industrial-Building”
in Cell “AE10”, “Office-in-IT-Park-SEZ”
in Cell “AE14”, “Warehouse-Godown”
Example marked in Grey colour

(B) Any data Starts after “-FOR-“ and ends before to next “-“ is a Transaction type.

For example in Cell “AD2”, “Sale” is Transaction
For example in Cell “AD3”, “Rent” is Transaction
For example in Cell “AD4”, “Temp” is Transaction
For example in Cell “AD5”, “Permanent” is Transaction
For example in Cell “AD6”, “Sale” is Transaction
Hence needed result as mentioned below
in Cell “AF2”, “Sale”
in Cell “AF3”, “Rent”
in Cell “AF4”, “Temp”
in Cell “AF5”, “Permanent”
in Cell “AF6”, “Sale”
Example marked in Green colour
(C) Any data Starts after the transaction and ends before “-in-“ is a Exact Location
i.e. Data after “-FOR-Sale-“ or “-FOR-Rent-“ or “-FOR-TEMP-“ or “-FOR-Permanent-“ or any other words (so you give me a option to add additional keyword also) and ends before “-in-“ is a exact Location
For example in Cell “AD2”, “Thakur-Village” is Exact Location
For example in Cell “AD3”, “Lower-Parel” is Exact Location
For example in Cell “AD4”, “Nariman-Point” is Exact Location
For example in Cell “AD5”, “Shayadri-Nagar-Charkop” is Exact Location
For example in Cell “AD6”, “Andheri-East” is Exact Location
For example in Cell “AD7”, “Bhiwendi” is Exact Location
For example in Cell “AD8”, “Kandivali-West” is Exact Location


Hence needed result as mentioned below
in Cell “AG2”, “Thakur-Village” is Exact Location
in Cell “AG3”, “Lower-Parel” is Exact Location
in Cell “AG4”, “Nariman-Point” is Exact Location
in Cell “AG5”, “Shayadri-Nagar-Charkop” is Exact Location
in Cell “AG6”, “Andheri-East” is Exact Location
in Cell “AG7”, “Bhiwendi” is Exact Location
in Cell “AG8”, “Kandivali-West” is Exact Location
Example marked in Red colour

existing code is

Sub Process_Latest()
Dim LastCol As Long
Dim lastRow As Long
Dim str As Variant
Dim ws As Worksheet: Set ws = Sheets("Paste data")
Dim vSplit As Variant
Dim rCell As Range
Dim cell As Range
Dim x, y(), i&, j&, arr, sp
Application.ScreenUpdating = False


'Add new sheet "Process Data"
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Process Data"
'Add new sheet "Web Harvy EMail ID"
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Web Harvy EMail ID"

'Code for Formula = "=SUBSTITUTE
'Dim LastCol As Long / Dim lastRow As Long (Variable)
With Sheets("Paste data")
lastRow = .Range("A1").CurrentRegion.Rows.Count
LastCol = .Range("A1").CurrentRegion.Columns.Count
End With
With Sheets("Process Data")
.Cells.ClearContents
.Range(.Cells(1, 1), .Cells(lastRow, LastCol)).Formula = "=SUBSTITUTE(CLEAN(TRIM('Paste Data'!A1)),CHAR(160),"""")"
End With

' Code to paste spacial the entire sheet
Sheets("Process Data").UsedRange.Value = Sheets("Process Data").UsedRange.Value

'Give Heading to 1st Column- PropertyCode
Sheets("Process data").Select
Range("A1").Value = "Property code"

'Replace text Property ID in column A
Columns("A:A").Replace What:="Property ID: ", Replacement:=""

'Code to insert coloumn next to date
Columns(3).EntireColumn.Delete

'Code to change Date format in Column B. (Dim i As Long /Dim str As Variant) are variable)
For i = 2 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 2) <> "" Then
str = Mid(Cells(i, 2), 10)
Cells(i, 3) = Mid(str, 5, 2) & "/" & Left(str, 3) & "/" & Right(str, 2)
End If
Next

'Give Heading to 3rd Column- Posted on
Range("C1").Value = "Posted on"

'Code to Delete coloumn next to date
Columns(2).EntireColumn.Delete

'Code to Insert coloumn next to Price
Columns(5).Resize(, 2).EntireColumn.Insert

'Code to clear contetnts next to ptice Coloumn
Range("E:G").ClearContents
Columns(5).EntireColumn.Insert
Columns("D:D").Replace What:=",", Replacement:=""

'code to convert numbe rto figure variable Dim ws As Worksheet: Set ws = Sheets("Paste data")
'Dim vSplit As Variant
'Dim rCell As Range

For Each rCell In ws.Range("D1:D" & ws.Range("D" & Rows.Count).End(xlUp).Row)
If Not InStr(1, Trim(rCell), " ") = 0 Then
vSplit = Split(Trim(rCell), " ")
Select Case UCase(vSplit(1))
Case Is = "THOUSAND"
rCell.Offset(, 1) = CLng(vSplit(0)) * 1000
Case Is = "LAC"
rCell.Offset(, 1) = CLng(vSplit(0)) * 100000
Case Is = "CR"
rCell.Offset(, 1) = CLng(vSplit(0)) * 10000000
End Select
Else
rCell.Offset(, 1) = rCell
End If
Next rCell

Columns(10).Resize(, 4).EntireColumn.Insert

'code to Extract Bathroom and bedroom Dim cell As Range
For Each cell In Range("I:I")
sp = Split(cell.Value, ",")
For i = 0 To UBound(sp)
Select Case True
Case InStr(2, sp(i), "Bedroom")
cell.Offset(, 1) = sp(i)
Case InStr(2, sp(i), "Bathroom")
cell.Offset(, 2) = sp(i)
Case Else
cell.Offset(, 3) = sp(i)
End Select
Next
Next


'Replace Bedrooms to BHK in column J
With Columns("J:J")
.Replace What:=" Bedrooms", Replacement:="BHK"
.Replace What:=" Bedroom", Replacement:="BHK"
.Replace What:="Bedrooms", Replacement:="BHK"
.Replace What:="Bedroom", Replacement:="BHK"
End With
'Code to clear contetnts Before an after Bedroom
Range("E:I,K:M").ClearContents

'Give Heading to 3rd Column- Posted on
Range("J1").Value = "Flat Type"

Columns("N:N").Replace What:="sqft sqyrd sqm acre bigha hectare marla kanal biswa1 biswa2 ground aankadam rood chatak kottah marla cent perch guntha are ", Replacement:=""

Columns(15).Resize(, 4).EntireColumn.Insert

'Replace text Property ID in column A
Columns("N:N").Replace What:="(covered)", Replacement:="(Covered Area) ", LookAt:=xlPart

'Replace text Property ID in column A
Columns("N:N").Replace What:="(carpet)", Replacement:="(Carpet Area) ", LookAt:=xlPart

'Replace text Property ID in column A
Columns("N:N").Replace What:="(plot)", Replacement:="(Plot Area) ", LookAt:=xlPart

'code to seperate area, covered plot, carpet Dim x, y(), i&, j&, arr, sp
x = Range("N1", Cells(Rows.Count, "N").End(xlUp)).Value
arr = Array("Covered Area", "Carpet Area", "Plot Area")
ReDim y(1 To UBound(x), 1 To UBound(arr) + 1)

For i = 1 To UBound(x)
For j = 0 To UBound(arr)
If InStr(x(i, 1), arr(j)) Then
sp = Split(Trim(Split(x(i, 1), arr(j))(0)))
y(i, j + 1) = sp(UBound(sp) - 3) & " " & sp(UBound(sp) - 2)
End If
Next j
Next i
Range("O1:Q1").Resize(i - 1).Value = y()
Range("O1:Q1").Value = arr
Application.ScreenUpdating = True

End Sub