Excel VBA - Auto ajuste de linha de célula mesclada

[Luciana Goes]

Pessoal, olá!

Uma dúvida. Não sei onde estou errando.

quando clico na célula mesclada da primeira linha, ela se auto ajusta certinho. Mas o que preciso mesmo é auto ajustar a célula da linha 6.

Segue o arquivo com o código. Será que alguém consegue me ajudar?

 

Pasta1.zip

[Midori]

@Luciana Goes Se rodar o código passo a passo inspecionando as variáveis, verá que no evento da linha 6 o endereço de c será B11 e não B6. Isso por causa desta atribuição,

Set c = Target.Cells(linha, 1)

 

Target é a célula ativa e com Cells você pegar outro endereço deslocando a quantidade de linhas/colunas passada para a função. Na primeira linha não teve problema porque só passou linha = 1. Mas para a outra passou linha = 6 e assim atribuiu com o deslocamento para o endereço B11. Para resolver é só deixar Cells(1, 1) já que deve atribuir a primeira célula da mescla.

[Luciana Goes]

@Midori Nossa, que simples! Resolveu meu problema!

Muito obrigada!

[Thiago Cherobim Candançan]

@Midori Tudo bem? Essa solução me ajudou bastante, só que  eu gostaria queria a linha ajustasse depois de escolher um valor lista suspensa da célula D1 para ajustar a C16, neste caso da Luciana só atualiza depois que clica na célula, consegue me ajudar?

[Midori]

@Thiago Cherobim Candançan Nesse caso use o evento Change e coloque sua macro na condicional da célula D1, p.ex,

 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$D$1" Then
    
    End If
End Sub

 

[Thiago Cherobim Candançan]

@Midori estou perdido de onde inserir, ainda sou novo em vba, apanho bastante rs

Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
Dim linha As Integer
linha = ActiveCell.Row



With Target

If .MergeCells And .WrapText Then

Set c = Target.Cells(linha, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea

For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next

Application.ScreenUpdating = False
On Error Resume Next
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
On Error GoTo 0
Application.ScreenUpdating = True
End If
End With
End Sub

 

[Midori]

@Thiago Cherobim Candançan É só colar o código dentro do If que comentei,

 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$D$1" Then
    
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
Dim linha As Integer
linha = ActiveCell.Row



With Target

If .MergeCells And .WrapText Then

Set c = Target.Cells(linha, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea

For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next

Application.ScreenUpdating = False
On Error Resume Next
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
On Error GoTo 0
Application.ScreenUpdating = True
End If
End With
End Sub

    End If
End Sub