I have done it, It looks little lengthy
Any suggestions for the improvement please
Option Explicit
Public FU_Visit As Worksheet
Public PD_Visit As Worksheet
Public RowLast_FUV As Long
Public RowLast_PDV As Long
Sub Init()
Set FU_Visit = Sheets("Follow-up Visit")
Set PD_Visit = Sheets("Paid Visit")
RowLast_FUV = FU_Visit.UsedRange.Rows.Count
RowLast_PDV = PD_Visit.UsedRange.Rows.Count
End Sub
Sub CkeckDates()
Dim pt As Range, ptRange As Range
Dim aryFUPtSplty() As String
Dim aryPDPtSplty() As String
Dim combined As String
Dim i As Long, j As Long, n As Long, k As Long, c As Long
Dim DiagArr As Variant
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Init
FU_Visit.Range("N2:O" & RowLast_FUV).ClearContents
ReDim aryFUPtSplty(2 To RowLast_FUV)
ReDim aryPDPtSplty(2 To RowLast_PDV)
Set ptRange = FU_Visit.Range("A2:A" & RowLast_FUV)
For Each pt In ptRange
combined = FU_Visit.Cells(pt.Row, "A") & FU_Visit.Cells(pt.Row, "E")
aryFUPtSplty(pt.Row) = combined
Next pt
Set ptRange = PD_Visit.Range("A2:A" & RowLast_PDV)
For Each pt In ptRange
combined = PD_Visit.Cells(pt.Row, "A") & PD_Visit.Cells(pt.Row, "E")
aryPDPtSplty(pt.Row) = combined
Next pt
For i = LBound(aryFUPtSplty) To UBound(aryFUPtSplty)
For j = LBound(aryPDPtSplty) To UBound(aryPDPtSplty)
If aryFUPtSplty(i) = aryPDPtSplty(j) Then
c = 0
If CLng(PD_Visit.Cells(j, "C")) <= CLng(FU_Visit.Cells(i, "C")) Then
If IsEmpty(FU_Visit.Cells(i, "N")) Then
DiagArr = Split(Trim(FU_Visit.Cells(i, "G")), ",")
For n = 0 To UBound(DiagArr)
k = InStr(1, Trim(PD_Visit.Cells(j, "G")), DiagArr(n))
If k > 0 Then
c = c + 1
FU_Visit.Cells(i, "N") = PD_Visit.Cells(j, "C")
FU_Visit.Cells(i, "O") = c
End If
Next n
ElseIf CLng(PD_Visit.Cells(j, "C")) >= CLng(FU_Visit.Cells(i, "N")) Then
DiagArr = Split(Trim(FU_Visit.Cells(i, "G")), ",")
For n = 0 To UBound(DiagArr)
k = InStr(1, Trim(PD_Visit.Cells(j, "G")), DiagArr(n))
If k > 0 Then
c = c + 1
FU_Visit.Cells(i, "N") = PD_Visit.Cells(j, "C")
FU_Visit.Cells(i, "O") = c
End If
Next n
End If
End If
End If
Next j
DoEvents
Application.StatusBar = "Processing : " & Format(i / UBound(aryFUPtSplty), "0%")
Next i
Erase aryFUPtSplty
Erase aryPDPtSplty
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub