none
Redimencionar celula ao conteúdo RRS feed

  • Pergunta

  • Bom dia

    Tenho algumas informações escritas em uma linha com celulas mescladas, mas não consigo achar a forma para redimencionar para que todo o texto apareça.

    Exemplo: celecionei da A20 até AM20, mesclei. Para aparecer todo o conteúdo da celula mesclada tenho que aumentar manualemente, mas quero que ele faça com uma macro. Como se fosse automático.
    Tenho várias celulas com informações, e variam algumas cabem dentro da celula mesclada outras não.
    terça-feira, 22 de outubro de 2013 13:40

Respostas

  • 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

    quinta-feira, 24 de outubro de 2013 01:35
    Moderador