Sub ReadCellContent()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

    Dim ColHeader As Range
    Set ColHeader = Range("A1", Range("A1").End(xlToRight))
    Dim ColData As Range
    
    For Each ColData In ColHeader
        If ColData.Offset(1, 0) = "" Then
            ColData.Interior.Color = vbYellow
        End If
       
        If ColData.Offset(1, 0) <> "" Then
            Dim ColRange As Range
            Dim lData As Range
            Set lData = Cells(Rows.Count, ColData.Column).End(xlUp)
            Set ColRange = Range(ColData.Offset(1, 0), lData)
            x = ColRange.Rows.Count
            y = WorksheetFunction.CountIf(ColRange, ColData.Offset(1, 0))
                If x = y Then
                 ColData.Interior.Color = vbGreen
                 Else
                 ColData.Interior.Color = vbRed
                 Range(ColData, lData).Select
                 Selection.Copy
                 Sheets.Add
                 ActiveSheet.Paste
                 Application.CutCopyMode = False
                 ActiveSheet.Range("A1", Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
                 Z = Range("A2", Range("A1").End(xlDown)).Count
                 i = Format(Z / x, "0.00%")
                 ActiveSheet.Delete
                 MsgBox i & " of cells are different in " & ColData.Value
                End If
        End If
          
    Next ColData
    
    Range("A1").Select
    
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub