ГСЭ.Ф. 1 	Философия
ГСЭ.Ф. 01 	Иностранный язык:лексический минимум в объеме  4000  учебных лексических единиц 

ГСЭ.Ф. 2 
ГСЭ.Ф. 3 
ГСЭ.Ф. 4 
ГСЭ.Ф. 5 
ГСЭ.Ф. 6 

        Else
                Set blank_cell = tocopy_.Cells(tocopy_.Range("a" & Rows.Count).End(xlUp).Row +  1 ,  1 )
                source_.Cells(cc.Row,  2 ).Copy blank_cell
                blank_cell.Offset( 0 ,  2 ).Value = "Not Exist In Sheets1 Column2!"

Option Explicit
Sub Сравнение()

Dim temp, temph
Dim source_ As Object, target_ As Object, tocopy_ As Object, x As Range
Dim iFirstAddress$, blank_cell As Range
Dim cc As Range

Set source_ = Sheets( 2 )
Set target_ = Sheets( 1 )
Set tocopy_ = Sheets( 3 )

For Each cc In source_.UsedRange.Columns( 2 ).Cells

temp = cc.Value
temph = source_.Cells(cc.Row,  5 ).Value

    If temp <> "" Then
        Set x = target_.Columns( 2 ).Find(temp, LookIn:=xlValues, lookat:=xlPart, MatchCase:=True)
        
        If Not x Is Nothing Then
        
            iFirstAddress = x.Address
                    
            Do
                Set x = target_.Columns( 2 ).FindNext(x)
                    If target_.Cells(x.Row,  3 ).Value <> temph Then
                            Set blank_cell = tocopy_.Cells(tocopy_.Range("a" & Rows.Count).End(xlUp).Row +  1 ,  1 )
                            source_.Cells(cc.Row,  2 ).Copy blank_cell
                    End If
            Loop While Not x Is Nothing And x.Address <> iFirstAddress
        Else
                Set blank_cell = tocopy_.Cells(tocopy_.Range("a" & Rows.Count).End(xlUp).Row +  1 ,  1 )
                source_.Cells(cc.Row,  2 ).Copy blank_cell
                blank_cell.Offset( 0 ,  2 ).Value = "Not Exist In Sheets1 Column2!"
        End If
    End If
Next

End Sub

Option Explicit
Sub Сравнение()

Dim temp$, temph$
Dim source_ As Object, target_ As Object, tocopy_ As Object, x As Range
Dim iFirstAddress$, blank_cell As Range
Dim cc As Range

Set source_ = Sheets( 2 )
Set target_ = Sheets( 1 )
Set tocopy_ = Sheets( 3 )

For Each cc In source_.UsedRange.Columns( 2 ).Cells
	temp = WorksheetFunction.Trim(cc.Value)
	temph = WorksheetFunction.Trim(source_.Cells(cc.Row,  5 ).Value)

    If temp <> "" Then
        Set x = target_.Columns( 2 ).Find(temp, LookIn:=xlValues, lookat:=xlPart, MatchCase:=True)
        If Not x Is Nothing Then
            iFirstAddress = x.Address
            Do
                Set x = target_.Columns( 2 ).FindNext(x)
                If WorksheetFunction.Trim(target_.Cells(x.Row,  3 ).Value) <> temph Then
                    Set blank_cell = tocopy_.Cells(tocopy_.Range("a" & Rows.Count).End(xlUp).Row +  1 ,  1 )
                    source_.Cells(cc.Row,  2 ).Copy blank_cell
                    blank_cell.Offset( 0 ,  1 ).Value = WorksheetFunction.Trim(target_.Cells(x.Row,  3 ).Value)
                    blank_cell.Offset( 0 ,  2 ).Value = temph
                End If
            Loop While Not x Is Nothing And x.Address <> iFirstAddress
        Else
                Set blank_cell = tocopy_.Cells(tocopy_.Range("a" & Rows.Count).End(xlUp).Row +  1 ,  1 )
                source_.Cells(cc.Row,  2 ).Copy blank_cell
                blank_cell.Offset( 0 ,  3 ).Value = "Not Exist In Sheets1 Column2!"
        End If
    End If
Next

End Sub