Jeg har et regneark i en projektmappe, der indeholder over 400 rækker, 8 kolonner og 160 flettede områder, og jeg forkludrede dets udseende. Jeg søgte på internettet efter VBA Autofit Merged Cells. Ingen af URL'erne er meget brugbare. Makroen på denne hjemmeside er på rette vej, men: -
1) Jeg bliver nødt til manuelt at identificere og indtaste de 160 fusionerede områder.
Jeg tilføjede en søgning efter flettede celleområder.
2) Den bruger række 1 til at udføre flettede celleberegninger (Cell ZZ1). Jeg bruger en meget større skrifttype på celle AXNUMX (Titel), hvilket resulterer i fejl ved beregning af den krævede flettede autotilpasningshøjde.
Jeg bruger en celle 1 kolonne til højre og 1 række under data. (Ctrl+Shift+End, finder ikke denne celle)
3) Det genberegner alle flettede celler, så det reducerede højden af to rækker, der indeholder både flettede og normale celler, hvilket gør de normale celler ulæselige.
Jeg ændrer kun rækkehøjden, når den nødvendige sammenlagte højde overstiger eksisterende højde.
4) Metoden til at kopiere data i flettede områder til celle ZZ1 er forkert, kun baseret på tekst i det flettede område, men uden hensyntagen til forskellige skriftstørrelser i forskellige flettede celler.
Jeg rettede kopieringsmetoden.
5) Makroen er langsom: omkring 15+ sekunder på mit regneark.
Hvis du slår skærmopdatering fra og tænder igen ved slutningen af makroen, reduceres dette til 2 sekunder.
Det lykkedes mig at finde en anden irriterende fejl. Autotilpas regnearket (før korrigering af de flettede områder), og det forvrængede flere rækker. Nogle "normale" celler, indstillet til ombrudt, fik deres højde øget og blev vist som en linje (eller to linjer) tekst med en tom række under teksten. Internetsøgning viste, at det er forårsaget af, at Excel har ændret skærmen, så den passer til printerskrifttyper. Fandt et "work around", jeg tilføjede til makroen:
Øg kolonnebredden med en lille procentdel.
Autotilpas alle rækker på regnearket.
Foretag rettelser til rækkehøjden for at imødekomme flettede områder.
Gendan kolonnebredden til originale størrelser.
Det løste det, tomme rækker vises nu ikke længere!
Troede, at alt nu var korrekt, men jeg opdagede så et yderligere problem. Hvis jeg lukker projektmappen og åbner den igen, er de tomme rækker tilbage igen. Kiggede på Filer/Indstillinger og jeg har søgt på internettet efter en metode til at forhindre projektmappen i at opdatere skærmvisningen ved lukning/åbning af projektmappen uden held. Jeg var nødt til at tilføje Private Sub Workbook_Open() på fanen "ThisWorkbook" med et opkald til at køre makroen, når projektmappen åbnes.
Mulighed for eksplicit
Sub Look4Merged()
Dim WSN As String 'Worksheet Name
Dim sht Som arbejdsark 'Brugt af "Set"
Dim LastRow As Long 'Sidste række i alle kolonner med data
Dim LastRowCC As Long 'Sidste række i nuværende kolonne med data
Dim LastColumn As Integer 'Antal sidste kolonne i alle rækker med data
Dim CurrCol As Integer 'Antal på nuværende kolonne
Dim bogstav som streng 'Konverter CurrCol-nummer til streng
Dim ILetter As String 'Indekskolonne et til højre for Sidste kolonne
Dæmp ICell As String 'Cell en kolonne til højre og en række nede fra dataområdet. Bruges til at beregne den nødvendige sammenlagte højde
Dæmp Crow As Long 'Current Row Number
Dim TwN As Long 'Fejlhåndtering
Dim TwD As String 'Fejlhåndtering
Dim Mgd As Boolean 'True/False test hvis celle er flettet
Dim MgdCellAddr As String 'Indeholder flettet område som en streng
Dim MgdCellStart As String 'Start bogstav for flettet celleområde Brugt f.eks. inspektion af kolonne B for flettede celler, ignorer eventuelle flettede celler, der starter i kolonne A, der udvider til kolonne B (allerede vurderet)
Dim MgdCellStart1 As String 'bruges til at beregne MgdCellStart
Dim MgdCellStart2 As String 'bruges til at beregne MgdCellStart
Dim OldHeight As Single 'Eksisterende højde på alle rækker i sammenlagt område
Dim P1 Som heltal 'Loop count/pointer
Dim OldWidth As Single 'Eksisterende bredde af celler i flettet område
Dim NewHeight As Single 'Påkrævet højde for alle rækker i sammenlagt område. Opdater individuelle rækker forholdsmæssigt, hvis det overstiger OldHeight
Dim C1 Som heltal 'Loop Kolonneantal
Dim R1 As Long 'Loop Row count/pointer
Dim Tweak As Single 'Lille stigning i kolonnebredde for at overvinde problemer med tomme rækker
Dim orRange As Range
Ved fejl GoTo TomsHandler
Application.ScreenUpdating = Falsk 'MEGET hurtigere 15 sekunder, hvis skærmen kun opdateres 2 sekunder slukket.
Tweak = 1.04 'Øg kolonnebredden med 4% før Autotilpas alle rækker.
WSN = ActiveSheet.Name
Columns("A:A").EntireRow.Hidden = False
'Find sidste aktive række og kolonne i hele regnearket med data
Med ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlForrige).Kolonne
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlForrige).Række
Slut med
CurrCol = LastColumn + 1 'dvs. til højre for sidste kolonne
Hvis CurrCol < 27 Så
ILetter = Chr$(CurrCol + 64) 'Indekskolonne
Else
ILetter = Chr$(Int((CurrCol - 1) / 26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) 'Indekskolonne hvis tocifret. har ikke generet med tredobbelt bogstav
End If
'Icell er placeret lige og under data. Celle bruges til at beregne den højde, der kræves for at passe til det flettede område
ICell = ILetter & LastRow + 1
'Øg kolonnebredden med en lille mængde for at helbrede indpakningsfejl i tomme rækker.
Range("A" & LastRow + 1). Vælg
For C1 = 1 til sidste kolonne
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Tweak 'øg kolonnebredden med en lille mængde for at afhjælpe fejl
ActiveCell.Offset(0, 1).Range("A1").Vælg ' flyt en celle til højre
Næste
'Autotilpas rækker (ignorerer flettede rækker) med kolonnebredde 4 % ekstra for at forhindre tomme rækker-fejl på nogle omviklingsrækker
Celler. Vælg
Udvælgelse.Rækker.Autotilpas
Set sht = Worksheets(WSN) 'nødvendig for at finde Sidste post i kolonne med data
For CurrCol = 1 til sidste kolonne
'konverter det nuværende kolonnenummer til alfa (enten enkelt- eller dobbeltbogstav)
Hvis CurrCol < 27 Så
Bogstav = Chr$(CurrCol + 64)
Else
Bogstav = Chr$(Int((CurrCol - 1) / 26) + 64)
Bogstav = Bogstav & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
End If
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Row 'find sidste række i den aktuelle kolonne
For CRow = 1 til LastRowCC
Rækkevidde (bogstav og CROW). Vælg
Mgd = ActiveCell.MergeCells 'Er celle i flettet område
Hvis Mgd = Sand Så 'Hvis Sandt, så er det
'Hvad er den flettede områdeadresse? udtræk enkelt-/dobbeltcifret for start af rækkevidde
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Mid(MgdCellAddr, 2, 1)
MgdCellStart2 = Mid(MgdCellAddr, 3, 1)
Hvis MgdCellStart2 = "$" Så
MgdCellStart = MgdCellStart1
Else
MgdCellStart = MgdCellStart1 & MgdCellStart2
End If
Hvis MgdCellStart = Bogstav Så 'Er flettet celle første kolonne lig med den aktuelle kolonne
Med ark (WSN)
OldWidth = 0
Set oRange = Range(MgdCellAddr) 'sæt oRange til Merged Range detekteret
For C1 = 1 Til oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, orange.Column + C1 - 1).ColumnWidth 'Akumuler kolonnebredder for celleområde (med 4 % tilføjet)
Næste
Gammel højde = 0
For R1 = 1 Til oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRow, orRange.Row + R1 - 1). RowHeight 'Akumuler eksisterende rækkehøjde for celleområde
Næste
oRange.MergeCells = Falsk
.Range(Letter & CRow).Copy Destination:=Range(ICell) 'Kopierer tekst OG skriftstørrelse, ikke kun værdier
.Range(ICell).WrapText = Sand 'wrap ICell
.Columns(ILetter).ColumnWidth = OldWidth 'ændr bredden af kolonne, der indeholder ICell for at efterligne eksisterende område
.Rows(LastRow + 1).EntireRow.AutoFit 'Autotilpas ICell-rækken, klar til at måle den påkrævede flettede højde
oRange.MergeCells = Sand 'Nulstil det flettede område tilbage til flettet
oRange.WrapText = Sand 'og indpakning
'Mål den nødvendige højde for sammenlagt rækkevidde
NewHeight = .Rows(Last Row + 1).RowHeight
'Overskrider den nye nødvendige højde den gamle eksisterende højde
Hvis NewHeight > OldHeight Så
For R1 = Crow To row + orRange.Rows.Count - 1
'Forøg hver række i rækkevidde pro rata
Range(ILetter & R1). Rækkehøjde = Range(ILetter & R1).Rækkehøjde * NewHeight / OldHeight
Næste
Else
'tilstrækkelig plads i fusioneret celle
End If
CRow = CRow + oRange.Rows.Count - 1 'else på multirow range, vil falde ned til 2. række af range og gentage beregningen, når du ankommer til "Next"
.Range(ICell). Ryd 'Zap ICell klar til næste beregning
.Range(ICell).ColumnWidth = 8.1 'Ryd op i kolonnebredden
Slut med
End If
End If
Næste
Næste
'Nulstil kolonnebredden, fjern 4 % tilføjet (nødvendig for at afhjælpe indpakningsfejl)
Range("A" & LastRow + 1). Vælg
For C1 = 1 til sidste kolonne
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak 'reducer kolonnebredden til originalen
ActiveCell.Offset(0, 1).Range("A1").Vælg ' en celle til højre
Næste
Range("A1"). Vælg
Application.ScreenUpdating = Ægte 'slå opdatering til igen
Exit Sub
TomsHandler:
Application.ScreenUpdating = Ægte 'slå opdatering til igen
TwN = Err.Number
TwD = Err.Description
MsgBox "Behov for at håndtere fejl" & TwN & " " & TwD
Stands
CV
End Sub
Er det muligt at forhindre Excel i at ændre skærmvisningens udseende ved lukning/genåbning af projektmappen?
1) Jeg bliver nødt til manuelt at identificere og indtaste de 160 fusionerede områder.
Jeg tilføjede en søgning efter flettede celleområder.
2) Den bruger række 1 til at udføre flettede celleberegninger (Cell ZZ1). Jeg bruger en meget større skrifttype på celle AXNUMX (Titel), hvilket resulterer i fejl ved beregning af den krævede flettede autotilpasningshøjde.
Jeg bruger en celle 1 kolonne til højre og 1 række under data. (Ctrl+Shift+End, finder ikke denne celle)
3) Det genberegner alle flettede celler, så det reducerede højden af to rækker, der indeholder både flettede og normale celler, hvilket gør de normale celler ulæselige.
Jeg ændrer kun rækkehøjden, når den nødvendige sammenlagte højde overstiger eksisterende højde.
4) Metoden til at kopiere data i flettede områder til celle ZZ1 er forkert, kun baseret på tekst i det flettede område, men uden hensyntagen til forskellige skriftstørrelser i forskellige flettede celler.
Jeg rettede kopieringsmetoden.
5) Makroen er langsom: omkring 15+ sekunder på mit regneark.
Hvis du slår skærmopdatering fra og tænder igen ved slutningen af makroen, reduceres dette til 2 sekunder.
Det lykkedes mig at finde en anden irriterende fejl. Autotilpas regnearket (før korrigering af de flettede områder), og det forvrængede flere rækker. Nogle "normale" celler, indstillet til ombrudt, fik deres højde øget og blev vist som en linje (eller to linjer) tekst med en tom række under teksten. Internetsøgning viste, at det er forårsaget af, at Excel har ændret skærmen, så den passer til printerskrifttyper. Fandt et "work around", jeg tilføjede til makroen:
Øg kolonnebredden med en lille procentdel.
Autotilpas alle rækker på regnearket.
Foretag rettelser til rækkehøjden for at imødekomme flettede områder.
Gendan kolonnebredden til originale størrelser.
Det løste det, tomme rækker vises nu ikke længere!
Troede, at alt nu var korrekt, men jeg opdagede så et yderligere problem. Hvis jeg lukker projektmappen og åbner den igen, er de tomme rækker tilbage igen. Kiggede på Filer/Indstillinger og jeg har søgt på internettet efter en metode til at forhindre projektmappen i at opdatere skærmvisningen ved lukning/åbning af projektmappen uden held. Jeg var nødt til at tilføje Private Sub Workbook_Open() på fanen "ThisWorkbook" med et opkald til at køre makroen, når projektmappen åbnes.
Mulighed for eksplicit
Sub Look4Merged()
Dim WSN As String 'Worksheet Name
Dim sht Som arbejdsark 'Brugt af "Set"
Dim LastRow As Long 'Sidste række i alle kolonner med data
Dim LastRowCC As Long 'Sidste række i nuværende kolonne med data
Dim LastColumn As Integer 'Antal sidste kolonne i alle rækker med data
Dim CurrCol As Integer 'Antal på nuværende kolonne
Dim bogstav som streng 'Konverter CurrCol-nummer til streng
Dim ILetter As String 'Indekskolonne et til højre for Sidste kolonne
Dæmp ICell As String 'Cell en kolonne til højre og en række nede fra dataområdet. Bruges til at beregne den nødvendige sammenlagte højde
Dæmp Crow As Long 'Current Row Number
Dim TwN As Long 'Fejlhåndtering
Dim TwD As String 'Fejlhåndtering
Dim Mgd As Boolean 'True/False test hvis celle er flettet
Dim MgdCellAddr As String 'Indeholder flettet område som en streng
Dim MgdCellStart As String 'Start bogstav for flettet celleområde Brugt f.eks. inspektion af kolonne B for flettede celler, ignorer eventuelle flettede celler, der starter i kolonne A, der udvider til kolonne B (allerede vurderet)
Dim MgdCellStart1 As String 'bruges til at beregne MgdCellStart
Dim MgdCellStart2 As String 'bruges til at beregne MgdCellStart
Dim OldHeight As Single 'Eksisterende højde på alle rækker i sammenlagt område
Dim P1 Som heltal 'Loop count/pointer
Dim OldWidth As Single 'Eksisterende bredde af celler i flettet område
Dim NewHeight As Single 'Påkrævet højde for alle rækker i sammenlagt område. Opdater individuelle rækker forholdsmæssigt, hvis det overstiger OldHeight
Dim C1 Som heltal 'Loop Kolonneantal
Dim R1 As Long 'Loop Row count/pointer
Dim Tweak As Single 'Lille stigning i kolonnebredde for at overvinde problemer med tomme rækker
Dim orRange As Range
Ved fejl GoTo TomsHandler
Application.ScreenUpdating = Falsk 'MEGET hurtigere 15 sekunder, hvis skærmen kun opdateres 2 sekunder slukket.
Tweak = 1.04 'Øg kolonnebredden med 4% før Autotilpas alle rækker.
WSN = ActiveSheet.Name
Columns("A:A").EntireRow.Hidden = False
'Find sidste aktive række og kolonne i hele regnearket med data
Med ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlForrige).Kolonne
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlForrige).Række
Slut med
CurrCol = LastColumn + 1 'dvs. til højre for sidste kolonne
Hvis CurrCol < 27 Så
ILetter = Chr$(CurrCol + 64) 'Indekskolonne
Else
ILetter = Chr$(Int((CurrCol - 1) / 26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) 'Indekskolonne hvis tocifret. har ikke generet med tredobbelt bogstav
End If
'Icell er placeret lige og under data. Celle bruges til at beregne den højde, der kræves for at passe til det flettede område
ICell = ILetter & LastRow + 1
'Øg kolonnebredden med en lille mængde for at helbrede indpakningsfejl i tomme rækker.
Range("A" & LastRow + 1). Vælg
For C1 = 1 til sidste kolonne
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Tweak 'øg kolonnebredden med en lille mængde for at afhjælpe fejl
ActiveCell.Offset(0, 1).Range("A1").Vælg ' flyt en celle til højre
Næste
'Autotilpas rækker (ignorerer flettede rækker) med kolonnebredde 4 % ekstra for at forhindre tomme rækker-fejl på nogle omviklingsrækker
Celler. Vælg
Udvælgelse.Rækker.Autotilpas
Set sht = Worksheets(WSN) 'nødvendig for at finde Sidste post i kolonne med data
For CurrCol = 1 til sidste kolonne
'konverter det nuværende kolonnenummer til alfa (enten enkelt- eller dobbeltbogstav)
Hvis CurrCol < 27 Så
Bogstav = Chr$(CurrCol + 64)
Else
Bogstav = Chr$(Int((CurrCol - 1) / 26) + 64)
Bogstav = Bogstav & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
End If
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Row 'find sidste række i den aktuelle kolonne
For CRow = 1 til LastRowCC
Rækkevidde (bogstav og CROW). Vælg
Mgd = ActiveCell.MergeCells 'Er celle i flettet område
Hvis Mgd = Sand Så 'Hvis Sandt, så er det
'Hvad er den flettede områdeadresse? udtræk enkelt-/dobbeltcifret for start af rækkevidde
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Mid(MgdCellAddr, 2, 1)
MgdCellStart2 = Mid(MgdCellAddr, 3, 1)
Hvis MgdCellStart2 = "$" Så
MgdCellStart = MgdCellStart1
Else
MgdCellStart = MgdCellStart1 & MgdCellStart2
End If
Hvis MgdCellStart = Bogstav Så 'Er flettet celle første kolonne lig med den aktuelle kolonne
Med ark (WSN)
OldWidth = 0
Set oRange = Range(MgdCellAddr) 'sæt oRange til Merged Range detekteret
For C1 = 1 Til oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, orange.Column + C1 - 1).ColumnWidth 'Akumuler kolonnebredder for celleområde (med 4 % tilføjet)
Næste
Gammel højde = 0
For R1 = 1 Til oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRow, orRange.Row + R1 - 1). RowHeight 'Akumuler eksisterende rækkehøjde for celleområde
Næste
oRange.MergeCells = Falsk
.Range(Letter & CRow).Copy Destination:=Range(ICell) 'Kopierer tekst OG skriftstørrelse, ikke kun værdier
.Range(ICell).WrapText = Sand 'wrap ICell
.Columns(ILetter).ColumnWidth = OldWidth 'ændr bredden af kolonne, der indeholder ICell for at efterligne eksisterende område
.Rows(LastRow + 1).EntireRow.AutoFit 'Autotilpas ICell-rækken, klar til at måle den påkrævede flettede højde
oRange.MergeCells = Sand 'Nulstil det flettede område tilbage til flettet
oRange.WrapText = Sand 'og indpakning
'Mål den nødvendige højde for sammenlagt rækkevidde
NewHeight = .Rows(Last Row + 1).RowHeight
'Overskrider den nye nødvendige højde den gamle eksisterende højde
Hvis NewHeight > OldHeight Så
For R1 = Crow To row + orRange.Rows.Count - 1
'Forøg hver række i rækkevidde pro rata
Range(ILetter & R1). Rækkehøjde = Range(ILetter & R1).Rækkehøjde * NewHeight / OldHeight
Næste
Else
'tilstrækkelig plads i fusioneret celle
End If
CRow = CRow + oRange.Rows.Count - 1 'else på multirow range, vil falde ned til 2. række af range og gentage beregningen, når du ankommer til "Next"
.Range(ICell). Ryd 'Zap ICell klar til næste beregning
.Range(ICell).ColumnWidth = 8.1 'Ryd op i kolonnebredden
Slut med
End If
End If
Næste
Næste
'Nulstil kolonnebredden, fjern 4 % tilføjet (nødvendig for at afhjælpe indpakningsfejl)
Range("A" & LastRow + 1). Vælg
For C1 = 1 til sidste kolonne
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak 'reducer kolonnebredden til originalen
ActiveCell.Offset(0, 1).Range("A1").Vælg ' en celle til højre
Næste
Range("A1"). Vælg
Application.ScreenUpdating = Ægte 'slå opdatering til igen
Exit Sub
TomsHandler:
Application.ScreenUpdating = Ægte 'slå opdatering til igen
TwN = Err.Number
TwD = Err.Description
MsgBox "Behov for at håndtere fejl" & TwN & " " & TwD
Stands
CV
End Sub
Er det muligt at forhindre Excel i at ændre skærmvisningens udseende ved lukning/genåbning af projektmappen?