option explicit
dim ffound
dim y, c
dim strCFTMS, strCFTMSInput
dim objExcel, objSheet, objWorkbook1, objWorkbook2, objSheet1, objSheet2

strCFTMSInput = "C:\CFT_MemberShip_list.csv"
'strCFTMS = "C:\CFT_UserList"&"_"&FormatDateTime(Date, 0)&".xlsx"
strCFTMS = "C:\CFT_MemberShip"&"_"&FormatDateTime(Date, 0)&".xlsx"

set objExcel = createObject("Excel.Application")
objExcel.DisplayAlerts = false
objExcel.Visible = ture

set objWorkbook1 = objExcel.Workbooks.Open(strCFTMSInput)
set objSheet1 = objWorkbook1.Sheets(1) 'csv
set objWorkbook2 = objExcel.Workbooks.Add
set objSheet2 = objWorkbook2.Sheets(1) 'xlsx


objSheet1.Activate
objSheet1.Range("A3:C2000").Select
objExcel.Selection.Copy
objSheet2.Activate
objSheet2.Range("A2:C2000").PasteSpecial -4163

objExcel.Cells(1,1).Value = "subj_name"
objExcel.Cells(1,1).Font.Bold = TRUE
objExcel.Columns(1).ColumnWidth = 43
objExcel.Cells(1,2).Value = "granted_throught"
objExcel.Cells(1,2).Font.Bold = TRUE
objExcel.Columns(2).ColumnWidth = 43
objExcel.Cells(1,3).Value = "final_granted"
objExcel.Cells(1,3).Font.Bold = TRUE
objExcel.Columns(3).ColumnWidth = 43

objExcel.Range("A1:C1").Interior.ColorIndex = 42

for y = 2 to 10000
ffound = find1(objExcel.Cells(y,1))  
	objExcel.Cells(y,7) = ffound
next

objExcel.Columns("A:C").Select
objExcel.Selection.AutoFilter
objSheet2.Range("A1").Select


objWorkbook2.SaveAS(strCFTMS),51
objWorkbook2.Saved = true

SET objSheet = NOTHING 
objExcel.Quit
objExcel.Quit()
SET objExcel = NOTHING

'=====================================================================
'=====================================================================

'SOME FUNCTIONS
Function find1(item)
Dim strFirstAddress As String
Set c = Worksheets("Лист1").Range("A:A").Find(item)
	If Not c Is Nothing Then
	strFirstAddress = c.Address
		Do
		'debug
        c.Select
        c.Offset(0, 1).Select
        'find the next assembly (calling itself)
        find1 (c.Offset(0, 1).Value)
        'Come back and findnext previous value
        Set c = Worksheets("Лист1").Range("A:A").FindNext(c)
        Loop While c.Address <> strFirstAddress
	    Else
	        WScript.Echo ("Cells Not Found")
    End If
End Function

Function find1(item)
Dim strFirstAddress
Set c = objSheet2.Range("A:A").Find(item)
	If Not c Is Nothing Then
	strFirstAddress = c.Address
		Do
                c.Select
                'WScript.Echo ("1")
		c.Offset(0, 1).Select
                'WScript.Echo ("2")
                'find the next assembly (calling itself)
                find1 (c.Offset(0, 1).Value)
		'WScript.Echo ("3")
		'Come back and find next previous value
 		Set c = objSheet2.Range("A:A").FindNext(c)
		'WScript.Echo ("4")
		Loop While c.Address = strFirstAddress
	        Else
	        WScript.Echo ("Cells Not Found")
    End If
End Function

'...
Set rToAnalyze = sh.Range("A1:C65536")
'...
aToAnalyze = rToAnalyze
'...

lRUpper = UBound(aToAnalyze, 1)
lCUpper = UBound(aToAnalyze, 2)

ReDim aResult(1 To lRUpper, 1 To lCUpper + 1)

aResult(1, lCUpper) = "GrantedThrough(n)"