Mary has several spreadsheets with between 10,000-80,000 rows each. Occasionally a column is wider than it should be, probably due to content making it wide. So, Mary wonders if there is an easy way to find the widest cell without scrolling through 10,000-80,000 rows to find it.

There are several ways to go about this, but for the purposes of this tip I'll only describe three of them. The first is an easy way if you can utilize a helper column in your worksheet. Let's say that the column you want to check is A. You could put this formula in the first cell of an unused column:

=LEN(TRIM(A1))

Copy the formula down as many cells as necessary, and then use the filtering capabilities of Excel to show the largest values in that column. This will give you those cells you desire.

The second formula-based way is to use a formula like these:

=MIN(IF(LEN($A:$A)=MAX(LEN($A:$A)),ROW($A:$A),1048577)) =CELL("address",INDEX($A:$A,MATCH(MAX(LEN($A:$A)),LEN($A:$A),0)))

Both of these should be entered as array formulas by pressing **Ctrl+Shift+Enter**. The first formula will return the row number of the cell in column A that has the longest length. The second formula returns the actual address of the cell with the longest length.

The third approach is good if you need to figure out the long lengths quite regularly. It involves using a macro to derive the necessary information:

Sub FindWidestCells() Dim Ad(10) As String Dim Le(10) As Integer Dim J As Integer Dim K As Integer Dim L As Integer Dim lCols As Long Dim lRows As Long Dim Rng As Range Dim c As Range Dim sTemp As String lCols = ActiveCell.Column lRows = Cells(Rows.Count, lCols).End(xlUp).Row Set Rng = Range(Cells(1, lCols), Cells(lRows, lCols)) For Each c In Rng ' Find shortest length in the group K = 1 For J = 2 To 10 If Le(J) < Le(K) Then K = J Next J If Len(c.Text) > Le(K) Then Le(K) = Len(c.Text) Ad(K) = c.Address 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 sTemp = "Longest cells:" & vbCr For J = 1 To 10 If Le(J) > 0 Then sTemp = sTemp & " " & Ad(J) & " (" & Le(J) & ")" & vbCr End If Next J MsgBox sTemp End Sub

All you need to do is to select a cell in the column you want to check and then run the macro. What is returned is a list of the 10 widest cells in the column, in descending order based on length.

*Note:*

If you would like to know how to use the macros described on this page (or on any other page on the *ExcelTips* sites), I've prepared a special page that includes helpful information. Click here to open that special page in a new browser tab.

*ExcelTips* is your source for cost-effective Microsoft Excel training.
This tip (13747) applies to Microsoft Excel 2007, 2010, 2013, 2016, 2019, and Excel in Office 365.

**Excel Smarts for Beginners!** Featuring the friendly and trusted *For Dummies* style, this popular guide shows beginners how to get up and running with Excel while also helping more experienced users get comfortable with the newest features. Check out *Excel 2013 For Dummies* today!

Want a quick way to insert a worksheet? There's nothing faster than using the handy shortcut.

Discover MoreMicrosoft added a new feature to Excel that causes a "lock icon" to appear at the left of a worksheet tab if the ...

Discover MoreFreezing the top rows in a worksheet so that they are always visible is easy to do. Freezing the bottom rows is not so ...

Discover More**FREE SERVICE:** Get tips like this every week in *ExcelTips,* a free productivity newsletter. Enter your address and click "Subscribe."

2020-03-17 11:37:45

J. Woolley

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

2020-03-16 10:49:30

J. Woolley

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.

2020-03-16 06:25:04

Willy Vanhaelen

Here is the right screen shot:

(see Figure 1 below)

**Figure 1.**

2020-03-16 06:19:50

Willy Vanhaelen

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

2020-03-15 11:55:10

J. Woolley

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.

2020-03-14 19:05:03

Brian

2020-03-14 16:54:23

J. Woolley

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

2020-03-14 05:57:04

John Tomp

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?

Got a version of Excel that uses the
ribbon interface (Excel 2007 or later)?
**This site is for you!** If you
use an earlier version of Excel, visit
our *ExcelTips* site focusing on the menu interface.

**FREE SERVICE:** Get tips like this every week in *ExcelTips,* a free productivity newsletter. Enter your address and click "Subscribe."

Copyright © 2020 Sharon Parq Associates, Inc.

## Comments