Dear Jerry,
Apologies for getting back to you this late. I have added some line of Code to the earlier one to show the percentage of different cells in a
Message Box. I hope you find it useful. Please let me know what you think.
Kunle
Code:
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