Utilize as rotinas abaixo :
Fonte:
Codigo para mesclar celulas iguais
http://comunidade.itlab.com.br/eve/foru ... /615602647
Option Explicit
Sub PreparaListaMesclada() 'By Badmoon
'Percorre a coluna atual verificando se o conteudo das celulas é igual, se
'for ira mescla-las e alinhar no centro
Dim lngLinha As Long
Dim lngProxima As Long
Dim strColuna As String
Dim lngColuna As Long
Dim strConteudo As String
Dim lngLinhaMesclar As Long
Dim lngCelulasEmBranco As Integer
Application.DisplayAlerts = False 'Desliga a confirmação do mesclar celulas
' lngColuna = ActiveCell.Column
lngColuna = 1
Do Until lngLinha = 1048576 'Percorre linha a linha ate a ultima da planilha
lngLinha = lngLinha + 1
lngLinhaMesclar = 0
'Pega Conteudo da celula atual
strConteudo = Cells(lngLinha, lngColuna).Formula
If strConteudo = vbNullString Then
lngCelulasEmBranco = lngCelulasEmBranco + 1
Else
lngCelulasEmBranco = 0
End If
'Mais de cinco celulas em branco entende como fim da lista
If lngCelulasEmBranco > 5 Then Exit Do
If Not strConteudo = vbNullString Then
For lngProxima = lngLinha + 1 To 1048576
If Cells(lngProxima, lngColuna).Formula = strConteudo Then
lngLinhaMesclar = lngProxima
Else
Exit For
End If
Next
If lngLinhaMesclar > 0 Then MesclaIntervalo lngLinha, lngLinhaMesclar, lngColuna
lngLinha = lngProxima - 1
End If
Loop
Cells(1, lngColuna).Select
Application.DisplayAlerts = True
MsgBox "Lista Pronta", vbOKOnly + vbExclamation, "Mesclar Lista"
End Sub
Private Sub MesclaIntervalo(Inicio, Fim, Coluna)
Range(Cells(Inicio, Coluna), Cells(Fim, Coluna)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter ' ou xlBottom ou xlTop
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
Selection.Merge
End Sub
[]s
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 01/07/2016 7:18 am