0
desfazer
Votos
Eu tenho uma planilha em uma pasta de trabalho contendo mais de 400 linhas, 8 colunas e 160 intervalos mesclados e estraguei sua aparência. Eu procurei na internet por VBA Autofit Merged Cells. Nenhum dos URLs são muito úteis. A macro neste site está no caminho certo, mas: -
1) Eu teria que identificar e digitar manualmente os 160 intervalos mesclados.
Eu adicionei uma pesquisa por intervalos de células mescladas.
2) Ele usa a primeira linha para fazer cálculos de células mescladas (Cell ZZ1). Eu uso uma fonte muito maior na célula A1 (Título), o que resulta em erros de cálculo da altura de ajuste automático mesclada necessária.
Eu uso uma célula 1 coluna à direita e 1 linha abaixo dos dados. (Ctrl+Shift+End, não encontra esta célula)
3) Ele recalcula todas as células mescladas para reduzir a altura de duas linhas contendo células mescladas e normais, tornando as células normais ilegíveis.
Eu altero a altura da linha apenas quando a altura mesclada necessária excede a altura existente.
4) O método para copiar dados em intervalos mesclados para a célula ZZ1 está incorreto, com base apenas no texto no intervalo mesclado, mas sem levar em conta os diferentes tamanhos de fonte em várias células mescladas.
Corrigi o método de cópia.
5) A macro é lenta: cerca de 15+ segundos na minha planilha.
Desligar a atualização da tela e ligá-la novamente no final da macro reduz isso para 2 segundos.
Consegui encontrar outra falha irritante. Ajuste automático da planilha (antes de corrigir os intervalos mesclados) e distorceu várias linhas. Algumas células “Normais”, configuradas para encapsuladas, tiveram sua altura aumentada e estavam aparecendo como uma linha (ou duas linhas) de texto com uma linha em branco abaixo do texto. A pesquisa na Internet indicou que é causado pelo Excel alterando a exibição para acomodar as fontes da impressora. Encontrei uma “contorna”, adicionei à macro:
Aumente as larguras das colunas em uma pequena porcentagem.
Ajuste automático de todas as linhas na planilha.
Execute correções na altura da linha para acomodar intervalos mesclados.
Reverta a largura da coluna para os tamanhos originais.
Isso corrigiu, as linhas em branco agora não estão mais aparecendo!
Pensei que tudo agora estava correto, mas então descobri um outro problema. Se eu fechar a pasta de trabalho e reabri-la novamente, as linhas em branco estarão de volta. Consultei Arquivo/Opções e pesquisei na Internet um método de impedir que a pasta de trabalho atualize a exibição da tela ao fechar/abrir a pasta de trabalho sem sucesso. Eu tive que adicionar Private Sub Workbook_Open() na guia “ThisWorkbook” com uma chamada para executar a macro quando a pasta de trabalho for aberta.
Opção explícita
Sub Look4Merged()
Dim WSN As String 'Nome da Planilha
Dim sht As Worksheet 'Usado por "Set"
Dim LastRow As Long 'Última linha em todas as colunas com dados
Dim LastRowCC As Long 'Última linha na coluna atual com dados
Dim LastColumn As Integer 'Número da última coluna em todas as linhas com dados
Dim CurrCol As Integer 'Número da coluna atual
Dim Letter As String 'Converte o número CurrCol em string
Dim ILetter As String 'Coluna de índice um à direita da última coluna
Dim ICell As String 'Cell uma coluna à direita e uma linha abaixo da área de dados frpm. Usado para calcular a altura mesclada necessária
Dim CRow As Long 'Número da Linha Atual
Dim TwN As Long 'Tratamento de erros
Dim TwD As String 'Tratamento de erros
Dim Mgd As Boolean 'True/False test se a célula for mesclada
Dim MgdCellAddr As String 'Contém o intervalo mesclado como uma string
Dim MgdCellStart As String 'Iniciar letra do intervalo de células mesclado Usado, por exemplo, inspecionando a Coluna B para células mescladas, ignore quaisquer células mescladas começando na Coluna A estendendo-se para a coluna B (já avaliada)
Dim MgdCellStart1 As String 'usado para calcular MgdCellStart
Dim MgdCellStart2 As String 'usado para calcular MgdCellStart
Dim OldHeight As Single 'Altura existente de todas as linhas no intervalo mesclado
Dim P1 As Integer 'Contagem/ponteiro de loop
Dim OldWidth As Single 'Largura existente das células no intervalo mesclado
Dim NewHeight As Single 'Altura necessária de todas as linhas no intervalo mesclado. Atualize linhas individuais proporcionalmente se exceder OldHeight
Dim C1 As Integer 'Loop Coluna count
Dim R1 As Long 'Loop Row contagem/ponteiro
Dim Tweak As Single 'Pequeno aumento na largura da coluna para superar o problema da linha em branco
Dim oRange como intervalo
Em erro, vá para TomsHandler
Application.ScreenUpdating = False 'MUITO mais rápido 15 segundos se a tela for atualizada apenas 2 segundos desligada.
Tweak = 1.04 'Aumenta a largura da coluna em 4% antes do Autoajuste de todas as linhas.
WSN = ActiveSheet.Nome
Columns("A:A").EntireRow.Hidden = False
'Localizar última linha e coluna ativa em toda a planilha com dados
Com ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlAnterior).Coluna
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlAnterior).Row
Terminar com
CurrCol = LastColumn + 1 'ie à direita da última coluna
Se CurrCol < 27 Então
ILetter = Chr$(CurrCol + 64) 'Coluna Índice
Outro
ILetter = Chr$(Int((CurrCol - 1)/26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) 'Coluna de índice se for de dois dígitos.
Se acabar
'Icell está localizado à direita e abaixo dos dados. A célula é usada para calcular a altura necessária para ajustar o intervalo mesclado
ICell = ILetter & LastRow + 1
'Aumentar a largura da coluna em uma pequena quantidade para corrigir o erro de quebra de linha em branco.
Range("A" & LastRow + 1). Selecione
Para C1 = 1 Para ÚltimaColuna
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Tweak 'aumentar a largura da coluna por uma pequena quantidade para curar o bug
ActiveCell.Offset(0, 1).Range("A1").Select ' move uma célula para a direita
Próximo
'Autofit Rows (ignora linhas mescladas) com largura de coluna 4% extra para evitar erros de linhas em branco em algumas linhas de quebra
Cells.Select
Seleção.Linhas.AutoAjuste
Set sht = Worksheets(WSN) 'necessário para encontrar a última entrada na coluna com dados
Para CurrCol = 1 para LastColumn
'converte o número da coluna atual para alfa (uma letra simples ou dupla)
Se CurrCol < 27 Então
Letra = Chr$(CurrCol + 64)
Outro
Letra = Chr$(Int((CurrCol - 1) / 26) + 64)
Letter = Letter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
Se acabar
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Row 'encontra a última linha na coluna atual
Para CRow = 1 Para LastRowCC
Intervalo (Letra e Crow). Selecione
Mgd = ActiveCell.MergeCells 'É a célula no intervalo mesclado
If Mgd = True Then 'Se True, então é
'Qual é o endereço do intervalo mesclado? extrair um/dois dígitos para o início do intervalo
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Médio(MgdCellAddr, 2, 1)
MgdCellStart2 = Médio(MgdCellAddr, 3, 1)
Se MgdCellStart2 = "$" Então
MgdCellStart = MgdCellStart1
Outro
MgdCellStart = MgdCellStart1 & MgdCellStart2
Se acabar
If MgdCellStart = Letter Then 'É a primeira coluna da célula mesclada igual à coluna atual
Com Planilhas (WSN)
Largura Antiga = 0
Set oRange = Range(MgdCellAddr) 'set oRange to Merged Range detectado
Para C1 = 1 Para oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, oRange.Column + C1 - 1).ColumnWidth 'Acumula larguras de coluna para intervalo de células (com 4% adicionados)
Próximo
Altura Antiga = 0
Para R1 = 1 Para oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRow, oRange.Row + R1 - 1).RowHeight 'Acumula a altura da linha existente para o intervalo de células
Próximo
oRange.MergeCells = Falso
.Range(Letter & CRow).Copy Destination:=Range(ICell) 'Copia texto E tamanho de fonte, não apenas valores
.Range(ICell).WrapText = True 'wrap ICell
.Columns(ILetter).ColumnWidth = OldWidth 'muda a largura da coluna contendo ICell para imitar o intervalo existente
.Rows(LastRow + 1).EntireRow.AutoFit 'Autoajuste a linha ICell, pronta para medir a altura mesclada necessária
oRange.MergeCells = True 'Redefinir o intervalo mesclado de volta para mesclado
oRange.WrapText = True 'e quebrando
'Mede a altura necessária para o intervalo mesclado
NovaAltura = .Rows(LastRow + 1).RowHeight
'A nova altura necessária excede a altura existente antiga
Se NewHeight > OldHeight Então
Para R1 = CRow Para CRow + oRange.Rows.Count - 1
'Aumenta cada linha no intervalo pro rata
Intervalo(Iletter & R1).RowHeight = Range(ILetter & R1).RowHeight * NewHeight / OldHeight
Próximo
Outro
'espaço suficiente na célula mesclada
Se acabar
CRow = CRow + oRange.Rows.Count - 1 'else no intervalo de várias linhas, cairá para a 2ª linha do intervalo e repetirá o cálculo ao chegar em "Próximo"
.Range(ICell).Clear 'Zap ICell pronto para o próximo cálculo
.Range(ICell).ColumnWidth = 8.1 'Arrumar a largura da coluna
Terminar com
Se acabar
Se acabar
Próximo
Próximo
'Redefinir a largura da coluna removendo 4% adicionados (necessário para curar o erro de encapsulamento)
Range("A" & LastRow + 1). Selecione
Para C1 = 1 Para ÚltimaColuna
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak 'reduz a largura da coluna para original
ActiveCell.Offset(0, 1).Range("A1").Selecione ' uma célula à direita
Próximo
Faixa("A1").Selecione
Application.ScreenUpdating = True 'switch atualizando novamente
Exit Sub
TomsHandler:
Application.ScreenUpdating = True 'switch atualizando novamente
TwN = Err.Número
TwD = Err.Descrição
MsgBox "Precisa tratar o erro " & TwN & " " & TwD
Dê um basta
CV
End Sub
É possível impedir que o Excel altere a aparência da tela ao fechar/reabrir a pasta de trabalho?
1) Eu teria que identificar e digitar manualmente os 160 intervalos mesclados.
Eu adicionei uma pesquisa por intervalos de células mescladas.
2) Ele usa a primeira linha para fazer cálculos de células mescladas (Cell ZZ1). Eu uso uma fonte muito maior na célula A1 (Título), o que resulta em erros de cálculo da altura de ajuste automático mesclada necessária.
Eu uso uma célula 1 coluna à direita e 1 linha abaixo dos dados. (Ctrl+Shift+End, não encontra esta célula)
3) Ele recalcula todas as células mescladas para reduzir a altura de duas linhas contendo células mescladas e normais, tornando as células normais ilegíveis.
Eu altero a altura da linha apenas quando a altura mesclada necessária excede a altura existente.
4) O método para copiar dados em intervalos mesclados para a célula ZZ1 está incorreto, com base apenas no texto no intervalo mesclado, mas sem levar em conta os diferentes tamanhos de fonte em várias células mescladas.
Corrigi o método de cópia.
5) A macro é lenta: cerca de 15+ segundos na minha planilha.
Desligar a atualização da tela e ligá-la novamente no final da macro reduz isso para 2 segundos.
Consegui encontrar outra falha irritante. Ajuste automático da planilha (antes de corrigir os intervalos mesclados) e distorceu várias linhas. Algumas células “Normais”, configuradas para encapsuladas, tiveram sua altura aumentada e estavam aparecendo como uma linha (ou duas linhas) de texto com uma linha em branco abaixo do texto. A pesquisa na Internet indicou que é causado pelo Excel alterando a exibição para acomodar as fontes da impressora. Encontrei uma “contorna”, adicionei à macro:
Aumente as larguras das colunas em uma pequena porcentagem.
Ajuste automático de todas as linhas na planilha.
Execute correções na altura da linha para acomodar intervalos mesclados.
Reverta a largura da coluna para os tamanhos originais.
Isso corrigiu, as linhas em branco agora não estão mais aparecendo!
Pensei que tudo agora estava correto, mas então descobri um outro problema. Se eu fechar a pasta de trabalho e reabri-la novamente, as linhas em branco estarão de volta. Consultei Arquivo/Opções e pesquisei na Internet um método de impedir que a pasta de trabalho atualize a exibição da tela ao fechar/abrir a pasta de trabalho sem sucesso. Eu tive que adicionar Private Sub Workbook_Open() na guia “ThisWorkbook” com uma chamada para executar a macro quando a pasta de trabalho for aberta.
Opção explícita
Sub Look4Merged()
Dim WSN As String 'Nome da Planilha
Dim sht As Worksheet 'Usado por "Set"
Dim LastRow As Long 'Última linha em todas as colunas com dados
Dim LastRowCC As Long 'Última linha na coluna atual com dados
Dim LastColumn As Integer 'Número da última coluna em todas as linhas com dados
Dim CurrCol As Integer 'Número da coluna atual
Dim Letter As String 'Converte o número CurrCol em string
Dim ILetter As String 'Coluna de índice um à direita da última coluna
Dim ICell As String 'Cell uma coluna à direita e uma linha abaixo da área de dados frpm. Usado para calcular a altura mesclada necessária
Dim CRow As Long 'Número da Linha Atual
Dim TwN As Long 'Tratamento de erros
Dim TwD As String 'Tratamento de erros
Dim Mgd As Boolean 'True/False test se a célula for mesclada
Dim MgdCellAddr As String 'Contém o intervalo mesclado como uma string
Dim MgdCellStart As String 'Iniciar letra do intervalo de células mesclado Usado, por exemplo, inspecionando a Coluna B para células mescladas, ignore quaisquer células mescladas começando na Coluna A estendendo-se para a coluna B (já avaliada)
Dim MgdCellStart1 As String 'usado para calcular MgdCellStart
Dim MgdCellStart2 As String 'usado para calcular MgdCellStart
Dim OldHeight As Single 'Altura existente de todas as linhas no intervalo mesclado
Dim P1 As Integer 'Contagem/ponteiro de loop
Dim OldWidth As Single 'Largura existente das células no intervalo mesclado
Dim NewHeight As Single 'Altura necessária de todas as linhas no intervalo mesclado. Atualize linhas individuais proporcionalmente se exceder OldHeight
Dim C1 As Integer 'Loop Coluna count
Dim R1 As Long 'Loop Row contagem/ponteiro
Dim Tweak As Single 'Pequeno aumento na largura da coluna para superar o problema da linha em branco
Dim oRange como intervalo
Em erro, vá para TomsHandler
Application.ScreenUpdating = False 'MUITO mais rápido 15 segundos se a tela for atualizada apenas 2 segundos desligada.
Tweak = 1.04 'Aumenta a largura da coluna em 4% antes do Autoajuste de todas as linhas.
WSN = ActiveSheet.Nome
Columns("A:A").EntireRow.Hidden = False
'Localizar última linha e coluna ativa em toda a planilha com dados
Com ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlAnterior).Coluna
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlAnterior).Row
Terminar com
CurrCol = LastColumn + 1 'ie à direita da última coluna
Se CurrCol < 27 Então
ILetter = Chr$(CurrCol + 64) 'Coluna Índice
Outro
ILetter = Chr$(Int((CurrCol - 1)/26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) 'Coluna de índice se for de dois dígitos.
Se acabar
'Icell está localizado à direita e abaixo dos dados. A célula é usada para calcular a altura necessária para ajustar o intervalo mesclado
ICell = ILetter & LastRow + 1
'Aumentar a largura da coluna em uma pequena quantidade para corrigir o erro de quebra de linha em branco.
Range("A" & LastRow + 1). Selecione
Para C1 = 1 Para ÚltimaColuna
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Tweak 'aumentar a largura da coluna por uma pequena quantidade para curar o bug
ActiveCell.Offset(0, 1).Range("A1").Select ' move uma célula para a direita
Próximo
'Autofit Rows (ignora linhas mescladas) com largura de coluna 4% extra para evitar erros de linhas em branco em algumas linhas de quebra
Cells.Select
Seleção.Linhas.AutoAjuste
Set sht = Worksheets(WSN) 'necessário para encontrar a última entrada na coluna com dados
Para CurrCol = 1 para LastColumn
'converte o número da coluna atual para alfa (uma letra simples ou dupla)
Se CurrCol < 27 Então
Letra = Chr$(CurrCol + 64)
Outro
Letra = Chr$(Int((CurrCol - 1) / 26) + 64)
Letter = Letter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
Se acabar
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Row 'encontra a última linha na coluna atual
Para CRow = 1 Para LastRowCC
Intervalo (Letra e Crow). Selecione
Mgd = ActiveCell.MergeCells 'É a célula no intervalo mesclado
If Mgd = True Then 'Se True, então é
'Qual é o endereço do intervalo mesclado? extrair um/dois dígitos para o início do intervalo
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Médio(MgdCellAddr, 2, 1)
MgdCellStart2 = Médio(MgdCellAddr, 3, 1)
Se MgdCellStart2 = "$" Então
MgdCellStart = MgdCellStart1
Outro
MgdCellStart = MgdCellStart1 & MgdCellStart2
Se acabar
If MgdCellStart = Letter Then 'É a primeira coluna da célula mesclada igual à coluna atual
Com Planilhas (WSN)
Largura Antiga = 0
Set oRange = Range(MgdCellAddr) 'set oRange to Merged Range detectado
Para C1 = 1 Para oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, oRange.Column + C1 - 1).ColumnWidth 'Acumula larguras de coluna para intervalo de células (com 4% adicionados)
Próximo
Altura Antiga = 0
Para R1 = 1 Para oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRow, oRange.Row + R1 - 1).RowHeight 'Acumula a altura da linha existente para o intervalo de células
Próximo
oRange.MergeCells = Falso
.Range(Letter & CRow).Copy Destination:=Range(ICell) 'Copia texto E tamanho de fonte, não apenas valores
.Range(ICell).WrapText = True 'wrap ICell
.Columns(ILetter).ColumnWidth = OldWidth 'muda a largura da coluna contendo ICell para imitar o intervalo existente
.Rows(LastRow + 1).EntireRow.AutoFit 'Autoajuste a linha ICell, pronta para medir a altura mesclada necessária
oRange.MergeCells = True 'Redefinir o intervalo mesclado de volta para mesclado
oRange.WrapText = True 'e quebrando
'Mede a altura necessária para o intervalo mesclado
NovaAltura = .Rows(LastRow + 1).RowHeight
'A nova altura necessária excede a altura existente antiga
Se NewHeight > OldHeight Então
Para R1 = CRow Para CRow + oRange.Rows.Count - 1
'Aumenta cada linha no intervalo pro rata
Intervalo(Iletter & R1).RowHeight = Range(ILetter & R1).RowHeight * NewHeight / OldHeight
Próximo
Outro
'espaço suficiente na célula mesclada
Se acabar
CRow = CRow + oRange.Rows.Count - 1 'else no intervalo de várias linhas, cairá para a 2ª linha do intervalo e repetirá o cálculo ao chegar em "Próximo"
.Range(ICell).Clear 'Zap ICell pronto para o próximo cálculo
.Range(ICell).ColumnWidth = 8.1 'Arrumar a largura da coluna
Terminar com
Se acabar
Se acabar
Próximo
Próximo
'Redefinir a largura da coluna removendo 4% adicionados (necessário para curar o erro de encapsulamento)
Range("A" & LastRow + 1). Selecione
Para C1 = 1 Para ÚltimaColuna
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak 'reduz a largura da coluna para original
ActiveCell.Offset(0, 1).Range("A1").Selecione ' uma célula à direita
Próximo
Faixa("A1").Selecione
Application.ScreenUpdating = True 'switch atualizando novamente
Exit Sub
TomsHandler:
Application.ScreenUpdating = True 'switch atualizando novamente
TwN = Err.Número
TwD = Err.Descrição
MsgBox "Precisa tratar o erro " & TwN & " " & TwD
Dê um basta
CV
End Sub
É possível impedir que o Excel altere a aparência da tela ao fechar/reabrir a pasta de trabalho?
Ainda não há respostas para esta postagem.