How to apply auto fit for the merged columns [Excel]

Hi All,

I’ve a requirement to apply auto fit for the merged columns and the text should be visible to read.
I’ve multiple excel files with different columns are merged.

Robot should read the excel file and find the merged columns and apply auto fit.

For example, one excel file D1 to H1 was merged i want to apply auto fit for the merged columns.
Example2: 2nd excel file C200 to G200 was merged

Can someone please help me is there any way to find that merged column and apply autofit.
TEST1.xlsx (9.0 KB)


Hi @Shagoul_Hameed,

Have you had a chance to check this link?


1 Like

Hi MY,

Thank you for the response, I’ve read this post this for to merge & unmerge the cells.

In my case the excel file already merged with few columns as I mentioned above.

I want only apply the “auto fit for the merged columns”.


Hi All,

I found a solution :blush: working fine.

Am sharing the script which will help if anyone wants to find a merged cell in the excel file and apply to autofit.

Sub FindMergedCells()
' Declare sheet you want to look for merged cells on - in the example it's sheet 1
Dim sheet As Worksheet
Set sheet = ActiveWorkbook.Sheets(1)
  Dim rng As Range
    Dim rngStart As Range
    Dim rngEnd As Range
Dim tHeight As Integer
Dim iPtr As Integer
Dim oldWidth As Double
Dim oldZZWidth As Double
Dim newWidth As Double
Dim newHeight As Double
Dim oRange As Range

' Add sheet for output
Dim output As Worksheet
Set output = Sheets.Add(after:=Sheets(1))
' Initialize row counter for output
orow = 0
' Header on output sheet

' Check all the cells in the worksheet's used range
For Each cell In sheet.UsedRange
    ' If they're merged -

        If cell.MergeCells Then
            orow = orow + 1
            Set cell = cell.MergeArea
            Set rngStart = cell.Cells(1, 1)
            Set rngEnd = cell.Cells(cell.Rows.Count, cell.Columns.Count)

            'MsgBox "First Cell " & rngStart.Address & vbNewLine & "Last Cell " & rngEnd.Address
            'output.Cells(orow, 1) = "" & Replace(rngStart.Address, "$", "") & ":" & Replace(rngEnd.Address, "$", "")
            Set oRange = Range("" & Replace(rngStart.Address, "$", "") & ":" & Replace(rngEnd.Address, "$", ""))
              With sheet
                  oldWidth = 0
                  For iPtr = 1 To oRange.Columns.Count
                    oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
                  Next iPtr
                  'oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
                  oRange.MergeCells = False
                  newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
                  oldZZWidth = .Range("ZZ1").ColumnWidth
                  .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
                  .Range("ZZ1").WrapText = True
                  .Columns("ZZ").ColumnWidth = oldWidth
                  newHeight = .Rows("1").RowHeight / oRange.Rows.Count
                  .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
                  oRange.MergeCells = True
                  oRange.WrapText = True
                  .Range("ZZ1").ColumnWidth = oldZZWidth
                End With

            'MsgBox "Not merged area"

            End If
Next cell
End Sub

1 Like

This topic was automatically closed 3 days after the last reply. New replies are no longer allowed.