Attribute VB_Name = "Module1"
Function FindNextStringValue(s As Long) As Long
    FindNextStringValue = s + 1
    If IsEmpty(Cells(FindNextStringValue, "A")) Then
        FindNextStringValue = -1
    End If
End Function


Function FindNextMainDepartmentStringValue(s As Long) As Long
    FindNextMainDepartmentStringValue = -1
    Dim curr As Long
    curr = s

    Do
        curr = FindNextStringValue(curr)
        If curr = -1 Then
            Exit Function
        End If
    Loop While IsEmpty(Cells(curr, "C"))
    FindNextMainDepartmentStringValue = curr
End Function


Sub CompareTwo(CurrLine As Long, NextLine As Long)
    If StrComp(UCase(Cells(CurrLine, "A")), UCase(Cells(NextLine, "A"))) = 0 Then
        If IsEmpty(Cells(CurrLine, "D")) Then
            Cells(CurrLine, "D").Value = CStr(Cells(CurrLine, "C").Value)
        End If

        If StrComp(Cells(CurrLine, "C").Value, Cells(CurrLine, "D").Value) = 0 Then
            Cells(CurrLine, "D").Font.Color = vbRed
        End If

        Cells(NextLine, "D").Value = CStr(Cells(CurrLine, "D").Value)
    End If
End Sub


Sub GetDefaultCell(c As Range)

    c.Font.Color = vbBlack
End Sub


Sub Fill()
    Dim CurrLine As Long
    CurrLine = 2

    Dim NextLine As Long

    Do
        NextLine = FindNextMainDepartmentStringValue(CurrLine)
        If NextLine <> -1 Then
            Call GetDefaultCell(Cells(CurrLine, "D"))
            'Cells(CurrLine, "E").Value = NextLine
            Call CompareTwo(CurrLine, NextLine)
            CurrLine = NextLine
        End If
    Loop While NextLine <> -1
End Sub