Am o foaie de lucru într-un registru de lucru care conține peste 400 de rânduri, 8 coloane și 160 de intervale îmbinate și i-am stricat aspectul. Am căutat pe internet VBA Autofit Merged Cells. Niciuna dintre adresele URL nu este de mare folos. Macrocomanda de pe acest site este pe drumul cel bun, dar: -
1) Ar trebui să identific și să introduc manual cele 160 de intervale îmbinate.
Am adăugat o căutare pentru intervale de celule îmbinate.
2) Utilizează rândul unu pentru a face calcule de celule îmbinate (Celula ZZ1). Folosesc un font mult mai mare pe celula A1 (Titlu), ceea ce are ca rezultat erori de calculare a înălțimii de potrivire automată îmbinată necesară.
Folosesc o celulă 1 coloană dreapta și 1 rând sub date. (Ctrl+Shift+End, nu găsește această celulă)
3) Recalculează toate celulele îmbinate, astfel încât a redus înălțimea a două rânduri care conțin atât celule îmbinate, cât și celule normale, făcând celulele normale imposibil de citit.
Modific înălțimea rândului numai atunci când înălțimea unită necesară depășește înălțimea existentă.
4) Metoda de copiere a datelor din intervalele îmbinate în celula ZZ1 este incorectă, bazată numai pe textul din intervalul îmbinat, dar fără a ține cont de dimensiunile diferite ale fonturilor din diferite celule îmbinate.
Am corectat metoda de copiere.
5) Macrocomanda este lentă: aproximativ 15+ secunde pe foaia mea de lucru.
Dezactivarea reîmprospătării ecranului și reactivarea la sfârșitul macrocomenzii reduce acest lucru la 2 secunde.
Am reușit să găsesc o altă greșeală iritantă. Potriviți automat foaia de lucru (înainte de a corecta intervalele îmbinate) și a distorsionat mai multe rânduri. Unele celule „normale”, setate la împachetat, aveau înălțimea crescută și apăreau ca o linie (sau două linii) de text cu un rând gol sub text. Căutarea pe internet a indicat că este cauzată de modificarea afișajului Excel pentru a se potrivi fonturilor imprimantei. Am găsit o „soluție”, am adăugat la macrocomandă:
Măriți lățimea coloanelor cu un procent mic.
Potriviți automat toate rândurile din foaia de lucru.
Efectuați corecții la înălțimea rândului pentru a se adapta intervalelor îmbinate.
Reveniți lățimea coloanei la dimensiunile originale.
Asta s-a rezolvat, rândurile goale nu mai apar acum!
Am crezut că acum totul este corect, dar apoi am descoperit o altă problemă. Dacă închid registrul de lucru și îl redeschid din nou, rândurile goale revin din nou. M-am uitat la Fișier/Opțiuni și am căutat pe Internet o metodă de a împiedica actualizarea registrului de lucru a afișajului ecranului la închiderea/deschiderea registrului de lucru fără succes. A trebuit să adaug Private Sub Workbook_Open() în fila „ThisWorkbook” cu un apel pentru a rula Macro atunci când registrul de lucru este deschis.
Opțiune explicită
Sub Look4Merged()
Dim WSN As String „Numele foii de lucru”.
Dim sht ca foaia de lucru „utilizată de „Set”
Dim LastRow As Long „Ultimul rând din toate coloanele cu date
Dim LastRowCC As Long „Ultimul rând din coloana curentă cu date
Dim LastColumn As Integer „Numărul ultimei coloane din toate rândurile cu date
Dim CurrCol As Integer „Numărul coloanei curente
Dim Letter As String „Convertiți numărul CurrCol în șir
Dim ILetter As String 'Indexați coloana unu la dreapta ultimei coloane
Dim ICell As String 'Celula o coloană la dreapta și un rând în jos în zona de date frpm. Folosit pentru a calcula înălțimea îmbinată necesară
Dim CRow As Long 'Numărul rândului curent
Dim TwN As Long „Manevrarea erorilor
Dim TwD As String „Manevrarea erorilor
Dim Mgd As Boolean „Test True/False dacă celula este îmbinată
Dim MgdCellAddr As String „Conține intervalul îmbinat ca șir
Dim MgdCellStart As String „Litera de început a intervalului de celule îmbinate Folosit, de exemplu, inspectarea coloanei B pentru celulele îmbinate, ignorați orice celule îmbinate care încep în coloana A și se extinde până la coloana B (deja evaluată)
Dim MgdCellStart1 As String 'utilizat pentru a calcula MgdCellStart
Dim MgdCellStart2 As String 'utilizat pentru a calcula MgdCellStart
Dim OldHeight As Single „Înălțimea existentă a tuturor rândurilor din intervalul îmbinat
Dim P1 As Integer 'Număr de bucle/pointer
Dim OldWidth As Single „Lățimea existentă a celulelor din intervalul îmbinat
Dim NewHeight As Single „Înălțimea necesară a tuturor rândurilor din intervalul îmbinat. Actualizați rândurile individuale proporțional dacă depășește OldHeight
Dim C1 As Integer 'Număr de coloane în buclă
Dim R1 As Long 'Loop Row count/pointer
Dim Tweak As Single „Mărire mică a lățimii coloanei pentru a depăși problema rândurilor goale
Dim portocaliu ca interval
La eroare Accesați TomsHandler
Application.ScreenUpdating = Fals „MULT mai rapid 15 secunde dacă ecranul a fost actualizat doar 2 secunde oprit.
Tweak = 1.04 „Măriți lățimea coloanei cu 4% înainte de Potrivire automată a tuturor rândurilor.
WSN = ActiveSheet.Name
Coloane("A:A").EntireRow.Hidden = False
„Găsiți ultimul rând și coloană activ în întreaga foaie de lucru cu date
Cu ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Se termina cu
CurrCol = LastColumn + 1, adică la dreapta ultimei coloane
Dacă CurrCol < 27 Atunci
ILetter = Chr$(CurrCol + 64) 'Coloană index
Altfel
ILlitera = Chr$(Int((CurrCol - 1) / 26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) „Coloană index dacă două cifre. nu m-am deranjat cu literă triplă
Final, dacă
„Icell este situat în dreapta și sub date. Celula este utilizată pentru a calcula înălțimea necesară pentru a se potrivi cu intervalul îmbinat
ICell = ILetter & LastRow + 1
„Măriți lățimea coloanei cu o cantitate mică pentru a vindeca eroarea de împachetare a rândurilor goale.
Interval(„A” și LastRow + 1).Selectați
Pentru C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Ajustați „mărește lățimea coloanei cu o cantitate mică pentru a vindeca eroarea
ActiveCell.Offset(0, 1).Range("A1").Selectați „mutați o celulă spre dreapta
Pagina Următoare →
„Ajustare automată a rândurilor (ignoră rândurile îmbinate) cu lățimea coloanei cu 4% în plus pentru a preveni erorile de rânduri goale pe unele rânduri de împachetare
Celule. Selectați
Selecție.Rânduri.Potrivire automată
Set sht = Worksheets(WSN) 'necesar pentru a găsi Ultima intrare în coloana cu date
Pentru CurrCol = 1 To LastColumn
„conversia numărul actual al coloanei în alfa (fie literă simplă, fie dublă)
Dacă CurrCol < 27 Atunci
Litera = Chr$(CurrCol + 64)
Altfel
Litera = Chr$(Int((CurrCol - 1) / 26) + 64)
Letter = Letter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
Final, dacă
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Row „găsește ultimul rând din coloana curentă”
Pentru CRow = 1 To LastRowCC
Interval(Literă și CROW).Selectați
Mgd = ActiveCell.MergeCells „Este celula în intervalul îmbinat
Dacă Mgd = Adevărat, atunci „Dacă Adevărat, atunci este
„Care este adresa zonei îmbinate? extrage o singură/dublă cifră pentru începutul intervalului
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Mid(MgdCellAddr, 2, 1)
MgdCellStart2 = Mid(MgdCellAddr, 3, 1)
Dacă MgdCellStart2 = "$" Atunci
MgdCellStart = MgdCellStart1
Altfel
MgdCellStart = MgdCellStart1 și MgdCellStart2
Final, dacă
Dacă MgdCellStart = Letter, atunci „Prima coloană a celulei este fuzionată egală cu coloana curentă
Cu foi (WSN)
OldWidth = 0
Set oRange = Range(MgdCellAddr) 'set oRange la Merged Range detectat
Pentru C1 = 1 To oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, oRange.Column + C1 - 1).ColumnWidth „Acumulează lățimile coloanei pentru intervalul de celule (cu 4% adăugat)
Pagina Următoare →
OldHeight = 0
Pentru R1 = 1 To oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRow, oRange.Row + R1 - 1).RowHeight „Acumulează înălțimea rândului existent pentru intervalul de celule
Pagina Următoare →
oRange.MergeCells = Fals
.Range(Letter & CRow).Copy Destination:=Range(ICell) „Copiază textul ȘI dimensiunea fontului, nu numai valorile
.Range(ICell).WrapText = Adevărat „înfășurare ICell
.Columns(ILetter).ColumnWidth = OldWidth „schimba lățimea coloanei care conține ICell pentru a imita intervalul existent
.Rows(LastRow + 1).EntireRow.AutoFit „Ajustează automat rândul ICell, gata să măsoare înălțimea îmbinată necesară
oRange.MergeCells = Adevărat „Resetează intervalul îmbinat la îmbinat
oRange.WrapText = Adevărat 'şi împachetare
„Măsurați înălțimea necesară pentru intervalul îmbinat
NewHeight = .Rows(LastRow + 1).RowHeight
„Noua înălțime necesară depășește înălțimea veche existentă?
Dacă NewHeight > OldHeight, atunci
Pentru R1 = CRow To CRow + oRange.Rows.Count - 1
„Măriți fiecare rând în interval pro rata
Interval(ILetter și R1).RowHeight = Interval(ILetter și R1).RowHeight * NewHeight / OldHeight
Pagina Următoare →
Altfel
„încăpere suficientă în celula îmbinată
Final, dacă
CRow = CRow + oRange.Rows.Count - 1 „altfel pe intervalul cu mai multe rânduri, va coborî pe al 2-lea rând de interval și va repeta calculul când ajungeți la „Următorul”
.Range(ICell).Ștergeți „Zap ICell gata pentru următorul calcul
.Range(ICell).ColumnWidth = 8.1 'Coordonați lățimea coloanei
Se termina cu
Final, dacă
Final, dacă
Pagina Următoare →
Pagina Următoare →
„Resetați lățimea coloanei eliminând 4% adăugat (necesar pentru a remedia eroarea de împachetare)
Interval(„A” și LastRow + 1).Selectați
Pentru C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak „reduce lățimea coloanei la original
ActiveCell.Offset(0, 1).Range("A1").Selectați 'o celulă la dreapta
Pagina Următoare →
Interval("A1").Selectați
Application.ScreenUpdating = Adevărat, repornește actualizarea
Ieșiți din Sub
TomsHandler:
Application.ScreenUpdating = Adevărat, repornește actualizarea
TwN = Err.Number
TwD = Err.Descriere
MsgBox „Trebuie să se ocupe de eroare” & TwN & " " & TwD
Stop
Relua
End Sub
Este posibil să împiedicați Excel să schimbe aspectul afișajului ecranului la închiderea/redeschiderea registrului de lucru?
1) Ar trebui să identific și să introduc manual cele 160 de intervale îmbinate.
Am adăugat o căutare pentru intervale de celule îmbinate.
2) Utilizează rândul unu pentru a face calcule de celule îmbinate (Celula ZZ1). Folosesc un font mult mai mare pe celula A1 (Titlu), ceea ce are ca rezultat erori de calculare a înălțimii de potrivire automată îmbinată necesară.
Folosesc o celulă 1 coloană dreapta și 1 rând sub date. (Ctrl+Shift+End, nu găsește această celulă)
3) Recalculează toate celulele îmbinate, astfel încât a redus înălțimea a două rânduri care conțin atât celule îmbinate, cât și celule normale, făcând celulele normale imposibil de citit.
Modific înălțimea rândului numai atunci când înălțimea unită necesară depășește înălțimea existentă.
4) Metoda de copiere a datelor din intervalele îmbinate în celula ZZ1 este incorectă, bazată numai pe textul din intervalul îmbinat, dar fără a ține cont de dimensiunile diferite ale fonturilor din diferite celule îmbinate.
Am corectat metoda de copiere.
5) Macrocomanda este lentă: aproximativ 15+ secunde pe foaia mea de lucru.
Dezactivarea reîmprospătării ecranului și reactivarea la sfârșitul macrocomenzii reduce acest lucru la 2 secunde.
Am reușit să găsesc o altă greșeală iritantă. Potriviți automat foaia de lucru (înainte de a corecta intervalele îmbinate) și a distorsionat mai multe rânduri. Unele celule „normale”, setate la împachetat, aveau înălțimea crescută și apăreau ca o linie (sau două linii) de text cu un rând gol sub text. Căutarea pe internet a indicat că este cauzată de modificarea afișajului Excel pentru a se potrivi fonturilor imprimantei. Am găsit o „soluție”, am adăugat la macrocomandă:
Măriți lățimea coloanelor cu un procent mic.
Potriviți automat toate rândurile din foaia de lucru.
Efectuați corecții la înălțimea rândului pentru a se adapta intervalelor îmbinate.
Reveniți lățimea coloanei la dimensiunile originale.
Asta s-a rezolvat, rândurile goale nu mai apar acum!
Am crezut că acum totul este corect, dar apoi am descoperit o altă problemă. Dacă închid registrul de lucru și îl redeschid din nou, rândurile goale revin din nou. M-am uitat la Fișier/Opțiuni și am căutat pe Internet o metodă de a împiedica actualizarea registrului de lucru a afișajului ecranului la închiderea/deschiderea registrului de lucru fără succes. A trebuit să adaug Private Sub Workbook_Open() în fila „ThisWorkbook” cu un apel pentru a rula Macro atunci când registrul de lucru este deschis.
Opțiune explicită
Sub Look4Merged()
Dim WSN As String „Numele foii de lucru”.
Dim sht ca foaia de lucru „utilizată de „Set”
Dim LastRow As Long „Ultimul rând din toate coloanele cu date
Dim LastRowCC As Long „Ultimul rând din coloana curentă cu date
Dim LastColumn As Integer „Numărul ultimei coloane din toate rândurile cu date
Dim CurrCol As Integer „Numărul coloanei curente
Dim Letter As String „Convertiți numărul CurrCol în șir
Dim ILetter As String 'Indexați coloana unu la dreapta ultimei coloane
Dim ICell As String 'Celula o coloană la dreapta și un rând în jos în zona de date frpm. Folosit pentru a calcula înălțimea îmbinată necesară
Dim CRow As Long 'Numărul rândului curent
Dim TwN As Long „Manevrarea erorilor
Dim TwD As String „Manevrarea erorilor
Dim Mgd As Boolean „Test True/False dacă celula este îmbinată
Dim MgdCellAddr As String „Conține intervalul îmbinat ca șir
Dim MgdCellStart As String „Litera de început a intervalului de celule îmbinate Folosit, de exemplu, inspectarea coloanei B pentru celulele îmbinate, ignorați orice celule îmbinate care încep în coloana A și se extinde până la coloana B (deja evaluată)
Dim MgdCellStart1 As String 'utilizat pentru a calcula MgdCellStart
Dim MgdCellStart2 As String 'utilizat pentru a calcula MgdCellStart
Dim OldHeight As Single „Înălțimea existentă a tuturor rândurilor din intervalul îmbinat
Dim P1 As Integer 'Număr de bucle/pointer
Dim OldWidth As Single „Lățimea existentă a celulelor din intervalul îmbinat
Dim NewHeight As Single „Înălțimea necesară a tuturor rândurilor din intervalul îmbinat. Actualizați rândurile individuale proporțional dacă depășește OldHeight
Dim C1 As Integer 'Număr de coloane în buclă
Dim R1 As Long 'Loop Row count/pointer
Dim Tweak As Single „Mărire mică a lățimii coloanei pentru a depăși problema rândurilor goale
Dim portocaliu ca interval
La eroare Accesați TomsHandler
Application.ScreenUpdating = Fals „MULT mai rapid 15 secunde dacă ecranul a fost actualizat doar 2 secunde oprit.
Tweak = 1.04 „Măriți lățimea coloanei cu 4% înainte de Potrivire automată a tuturor rândurilor.
WSN = ActiveSheet.Name
Coloane("A:A").EntireRow.Hidden = False
„Găsiți ultimul rând și coloană activ în întreaga foaie de lucru cu date
Cu ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Se termina cu
CurrCol = LastColumn + 1, adică la dreapta ultimei coloane
Dacă CurrCol < 27 Atunci
ILetter = Chr$(CurrCol + 64) 'Coloană index
Altfel
ILlitera = Chr$(Int((CurrCol - 1) / 26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) „Coloană index dacă două cifre. nu m-am deranjat cu literă triplă
Final, dacă
„Icell este situat în dreapta și sub date. Celula este utilizată pentru a calcula înălțimea necesară pentru a se potrivi cu intervalul îmbinat
ICell = ILetter & LastRow + 1
„Măriți lățimea coloanei cu o cantitate mică pentru a vindeca eroarea de împachetare a rândurilor goale.
Interval(„A” și LastRow + 1).Selectați
Pentru C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Ajustați „mărește lățimea coloanei cu o cantitate mică pentru a vindeca eroarea
ActiveCell.Offset(0, 1).Range("A1").Selectați „mutați o celulă spre dreapta
Pagina Următoare →
„Ajustare automată a rândurilor (ignoră rândurile îmbinate) cu lățimea coloanei cu 4% în plus pentru a preveni erorile de rânduri goale pe unele rânduri de împachetare
Celule. Selectați
Selecție.Rânduri.Potrivire automată
Set sht = Worksheets(WSN) 'necesar pentru a găsi Ultima intrare în coloana cu date
Pentru CurrCol = 1 To LastColumn
„conversia numărul actual al coloanei în alfa (fie literă simplă, fie dublă)
Dacă CurrCol < 27 Atunci
Litera = Chr$(CurrCol + 64)
Altfel
Litera = Chr$(Int((CurrCol - 1) / 26) + 64)
Letter = Letter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
Final, dacă
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Row „găsește ultimul rând din coloana curentă”
Pentru CRow = 1 To LastRowCC
Interval(Literă și CROW).Selectați
Mgd = ActiveCell.MergeCells „Este celula în intervalul îmbinat
Dacă Mgd = Adevărat, atunci „Dacă Adevărat, atunci este
„Care este adresa zonei îmbinate? extrage o singură/dublă cifră pentru începutul intervalului
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Mid(MgdCellAddr, 2, 1)
MgdCellStart2 = Mid(MgdCellAddr, 3, 1)
Dacă MgdCellStart2 = "$" Atunci
MgdCellStart = MgdCellStart1
Altfel
MgdCellStart = MgdCellStart1 și MgdCellStart2
Final, dacă
Dacă MgdCellStart = Letter, atunci „Prima coloană a celulei este fuzionată egală cu coloana curentă
Cu foi (WSN)
OldWidth = 0
Set oRange = Range(MgdCellAddr) 'set oRange la Merged Range detectat
Pentru C1 = 1 To oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, oRange.Column + C1 - 1).ColumnWidth „Acumulează lățimile coloanei pentru intervalul de celule (cu 4% adăugat)
Pagina Următoare →
OldHeight = 0
Pentru R1 = 1 To oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRow, oRange.Row + R1 - 1).RowHeight „Acumulează înălțimea rândului existent pentru intervalul de celule
Pagina Următoare →
oRange.MergeCells = Fals
.Range(Letter & CRow).Copy Destination:=Range(ICell) „Copiază textul ȘI dimensiunea fontului, nu numai valorile
.Range(ICell).WrapText = Adevărat „înfășurare ICell
.Columns(ILetter).ColumnWidth = OldWidth „schimba lățimea coloanei care conține ICell pentru a imita intervalul existent
.Rows(LastRow + 1).EntireRow.AutoFit „Ajustează automat rândul ICell, gata să măsoare înălțimea îmbinată necesară
oRange.MergeCells = Adevărat „Resetează intervalul îmbinat la îmbinat
oRange.WrapText = Adevărat 'şi împachetare
„Măsurați înălțimea necesară pentru intervalul îmbinat
NewHeight = .Rows(LastRow + 1).RowHeight
„Noua înălțime necesară depășește înălțimea veche existentă?
Dacă NewHeight > OldHeight, atunci
Pentru R1 = CRow To CRow + oRange.Rows.Count - 1
„Măriți fiecare rând în interval pro rata
Interval(ILetter și R1).RowHeight = Interval(ILetter și R1).RowHeight * NewHeight / OldHeight
Pagina Următoare →
Altfel
„încăpere suficientă în celula îmbinată
Final, dacă
CRow = CRow + oRange.Rows.Count - 1 „altfel pe intervalul cu mai multe rânduri, va coborî pe al 2-lea rând de interval și va repeta calculul când ajungeți la „Următorul”
.Range(ICell).Ștergeți „Zap ICell gata pentru următorul calcul
.Range(ICell).ColumnWidth = 8.1 'Coordonați lățimea coloanei
Se termina cu
Final, dacă
Final, dacă
Pagina Următoare →
Pagina Următoare →
„Resetați lățimea coloanei eliminând 4% adăugat (necesar pentru a remedia eroarea de împachetare)
Interval(„A” și LastRow + 1).Selectați
Pentru C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak „reduce lățimea coloanei la original
ActiveCell.Offset(0, 1).Range("A1").Selectați 'o celulă la dreapta
Pagina Următoare →
Interval("A1").Selectați
Application.ScreenUpdating = Adevărat, repornește actualizarea
Ieșiți din Sub
TomsHandler:
Application.ScreenUpdating = Adevărat, repornește actualizarea
TwN = Err.Number
TwD = Err.Descriere
MsgBox „Trebuie să se ocupe de eroare” & TwN & " " & TwD
Stop
Relua
End Sub
Este posibil să împiedicați Excel să schimbe aspectul afișajului ecranului la închiderea/redeschiderea registrului de lucru?