Eu odeio o acesso às propriedades de largura de coluna do Excel.
Sua solicitação, embora simples, nos leva à um código feio e complexo:
Dim msngCharFactor As Single
Dim msngMarginPoints As Single
Sub fncMain()
Dim sngTotal As Single
Dim rngCol As Range
Dim lngCol As Long
Dim rngSource As Range
Dim wksNew As Worksheet
Dim sngLargeWidth As Single
fncGetScale msngCharFactor, msngMarginPoints
Set rngSource = Selection
If Not (rngSource.MergeCells = True And rngSource.Columns.Count > 1) Then
MsgBox "Selecione uma célula mesclada que possua mais de uma coluna.", vbCritical
End If
For Each rngCol In rngSource.Columns
If rngCol.Address <> rngSource.Columns(1).Address Then
sngTotal = sngTotal + fncColumnWidth2WidthX(rngCol.ColumnWidth)
End If
Next rngCol
Application.ScreenUpdating = False
Set wksNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rngSource.Copy
With wksNew.Range(rngSource.Address)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
.UnMerge
.EntireColumn.AutoFit
sngLargeWidth = .Columns(1).ColumnWidth
End With
wksNew.Parent.Close SaveChanges:=False
rngSource.Columns(1).ColumnWidth = sngLargeWidth - fncWidth2ColumnWidthX(sngTotal)
Application.ScreenUpdating = True
End Sub
Private Function fncColumnWidth2WidthX(sngColumnWidth As Single) As Single
fncColumnWidth2WidthX = (sngColumnWidth * msngCharFactor) + msngMarginPoints
End Function
Private Function fncWidth2ColumnWidthX(sngWidth As Single) As Single
fncWidth2ColumnWidthX = (sngWidth - msngMarginPoints) / msngCharFactor
End Function
Private Sub fncGetScale(sngCharFactor, sngMarginPoints, Optional wkb As Workbook)
Dim wkbTemp As Excel.Workbook
Dim stl As Excel.Style
Dim strDefault As String
Dim dblX1 As Double
Dim dblX2 As Double
Dim dblY1 As Double
Dim dblY2 As Double
Application.ScreenUpdating = False
If wkb Is Nothing Then Set wkb = ActiveWorkbook
Set wkbTemp = Application.Workbooks.Add
'Descobrir nome do estilo "Normal"
On Error Resume Next
For Each stl In wkbTemp.Styles
stl.Delete
Next stl
On Error GoTo 0
strDefault = wkbTemp.Styles(1).Name
With wkbTemp.Styles(strDefault).Font
.Name = wkb.Styles(strDefault).Font.Name
.Size = wkb.Styles(strDefault).Font.Size
.Bold = wkb.Styles(strDefault).Font.Bold
.Italic = wkb.Styles(strDefault).Font.Italic
End With
dblX1 = CDbl(1)
dblX2 = CDbl(255)
wkbTemp.Sheets(1).Columns(1).ColumnWidth = dblX1
dblY1 = wkbTemp.Sheets(1).Columns(1).Width
wkbTemp.Sheets(1).Columns(1).ColumnWidth = dblX2
dblY2 = wkbTemp.Sheets(1).Columns(1).Width
sngCharFactor = (dblY2 - dblY1) / (dblX2 - dblX1)
sngMarginPoints = dblY1 - dblX1 * sngCharFactor
wkbTemp.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Você pode melhorar o código armazeando os valores das escala msngCharFactor e msngMarginPoints numa variável estática ou de módulo para evitar seu cálculo toda vez que executar o subprocedimento.
Além disso, se você necessita dessa rotina em várias células mescladas, sugiro criar uma pasta de trabalho temporária uma vez, copiar todos intervalos temporários nela ajustando, assim, os tamanhos ideais de coluna, e depois fechá-la.
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
