Finding the Widest Cell Contents

@Willy Vanhaelen
This simple fix added to the top of your macro is better than the one I posted yesterday because it allows for a discontinuous Selection and chooses the column containing ActiveCell:
Intersect(Selection, Columns(ActiveCell.Column)).Select

@Willy Vanhaelen
Your macro is excellent, but it fails if Selection has more than one column. A simple fix is to add at the top:
Selection.Columns(1).Select
But it would be better to analyze each column.
Your formatted image is a great idea. Too bad it does not permit copy/paste.

Here is the right screen shot:
(see Figure 1 below)

@John Tomp
You are right, the number of characters doesn’t necessarily correspond with the space needed to fill a cell. Besides the macro doesn’t do what is asked for namely simply finding the cell taking the widest cell contents. Here is a relatively simple macro that just does what is asked for:

Sub Widest()
Dim cell As Range, R As Long
Dim X As Long, Y As Long, Z As Long
Application.ScreenUpdating = False
X = 0
Y = Selection.Row
Z = Selection.Cells(1).ColumnWidth
For Each cell In Selection
If Len(cell) > 0 Then
cell.Columns.AutoFit
If cell.ColumnWidth > X Then
X = cell.ColumnWidth
R = Y
End If
End If
Y = Y + 1
Next
ActiveSheet.Cells(R, Selection.Column).Select
Selection.Cells(1).ColumnWidth = Z
Application.ScreenUpdating = True
End Sub

Here is a screen shot that shows the right indentation but don't copy it.

Sub Widest()
Dim cell As Range, R As Long
Dim X As Long, Y As Long, Z As Long
Application.ScreenUpdating = False
X = 0
Y = Selection.Row
Z = Selection.Cells(1).ColumnWidth
For Each cell In Selection
If Len(cell) > 0 Then
cell.Columns.AutoFit
If cell.ColumnWidth > X Then
X = cell.ColumnWidth
R = Y
End If
End If
Y = Y + 1
Next
ActiveSheet.Cells(R, Selection.Column).Select
Selection.Cells(1).ColumnWidth = Z
Application.ScreenUpdating = True
End Sub

The macro I posted March 14 works better when this one line
Cells(tmpRow, tmpCol).PasteSpecial Paste:=xlPasteValues
is followed by these two additional lines
Cells(tmpRow, tmpCol).PasteSpecial Paste:=xlPasteFormats
Cells(tmpRow, tmpCol).PasteSpecial Paste:=xlPasteColumnWidths
which account for different formats including wrap text.

The solution depends on what is meant by "widest". Looks like you've interpreted that to mean "most characters/digits", but that doesn't necessarily mean "widest". For example, the string "WWWWWWW" (7 characters) is much "wider" in most proportional fonts than ".........." (10 characters), even though the W string has fewer characters. If Mary had wanted to find the cell with the actual "widest width", can that be done?

Here is a modified version of the macro using each cell's actual width, not its character count. (Apologies for poor VBA code format when posting comments here.)

Sub FindWidestCells()
Dim Ad(1 To 10) As String
Dim Le(1 To 10) As Integer
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim tmpCol As Long
Dim tmpRow As Long
Dim lCols As Long
Dim lRows As Long
Dim Rng As Range
Dim Ac As Range
Dim c As Range
Dim sTemp As String
Application.ScreenUpdating = False
With ActiveSheet
tmpCol = .UsedRange.Column + .UsedRange.Columns.Count
tmpRow = .UsedRange.Row + .UsedRange.Rows.Count
End With
lCols = ActiveCell.Column
lRows = Cells(Rows.Count, lCols).End(xlUp).Row
Set Rng = Range(Cells(1, lCols), Cells(lRows, lCols))
Set Ac = ActiveCell
' Find shortest length in the group
For Each c In Rng
If Not IsEmpty(c.Value) Then
K = 1
For J = 2 To 10
If Le(J) <= Le(K) Then K = J
Next J
c.Copy
Cells(tmpRow, tmpCol).PasteSpecial Paste:=xlPasteValues
With Columns(tmpCol)
.AutoFit
If .Width > Le(K) Then
Le(K) = .Width
Ad(K) = c.Address
End If
.Delete
End With
End If
Next c
' Sort the cells
For J = 1 To 9
L = J
For K = J + 1 To 10
If Le(K) > Le(L) Then L = K
Next K
If L <> J Then
sTemp = Ad(L)
Ad(L) = Ad(J)
Ad(J) = sTemp
K = Le(L)
Le(L) = Le(J)
Le(J) = K
End If
Next J
' Report results
sTemp = "Widest cells (points):" & vbNewLine
If Le(1) = 0 Then
sTemp = sTemp & "this column is empty" & vbNewLine
Else
For J = 1 To 10
If Le(J) > 0 Then
sTemp = sTemp & " " & Ad(J) & " (" & Le(J) & ")" & vbNewLine
End If
Next J
Set Ac = Range(Ad(1))
End If
Application.ScreenUpdating = True
Ac.Activate
Ac.Show
MsgBox sTemp
End Sub

Hello
Your methods donet actually calculate the width of the cells, they calculate the number of characters. Now a cell with 10 'i"s is much narrower than one with 10 "m"s (to take extreme values). And if you want to optimise cell width you need actual width not number of characters. Is there a way to do that?