Έχω ένα φύλλο εργασίας σε ένα βιβλίο εργασίας που περιέχει περισσότερες από 400 σειρές, 8 στήλες και 160 συγχωνευμένες περιοχές και μπέρδεψα την εμφάνισή του. Έψαξα στο διαδίκτυο για VBA Autofit Merged Cells. Καμία από τις διευθύνσεις URL δεν είναι πολύ χρήσιμη. Η μακροεντολή σε αυτόν τον ιστότοπο είναι στο σωστό δρόμο, αλλά: -
1) Θα έπρεπε να αναγνωρίσω και να πληκτρολογήσω με μη αυτόματο τρόπο τις 160 συγχωνευμένες περιοχές.
Πρόσθεσα μια αναζήτηση για συγχωνευμένες περιοχές κελιών.
2) Χρησιμοποιεί τη σειρά πρώτη για να κάνει υπολογισμούς συγχωνευμένων κελιών (Κελί ZZ1). Χρησιμοποιώ μια πολύ μεγαλύτερη γραμματοσειρά στο κελί A1 (Τίτλος) που έχει ως αποτέλεσμα σφάλματα στον υπολογισμό του απαιτούμενου ύψους αυτόματης προσαρμογής.
Χρησιμοποιώ ένα κελί 1 στήλη δεξιά και 1 γραμμή κάτω από τα δεδομένα. (Ctrl+Shift+End, δεν βρίσκει αυτό το κελί)
3) Υπολογίζει εκ νέου όλα τα συγχωνευμένα κελιά, επομένως μείωσε το ύψος δύο σειρών που περιέχουν συγχωνευμένα και κανονικά κελιά κάνοντας τα κανονικά κελιά μη αναγνώσιμα.
Αλλάζω το ύψος της σειράς μόνο όταν το απαιτούμενο συγχωνευμένο ύψος υπερβαίνει το υπάρχον ύψος.
4) Η μέθοδος για την αντιγραφή δεδομένων σε συγχωνευμένες περιοχές στο κελί ZZ1 είναι εσφαλμένη, βασίζεται μόνο στο κείμενο στη συγχωνευμένη περιοχή, αλλά δεν λαμβάνει υπόψη τα διαφορετικά μεγέθη γραμματοσειράς σε διάφορα συγχωνευμένα κελιά.
Διόρθωσα τη μέθοδο αντιγραφής.
5) Η μακροεντολή είναι αργή: περίπου 15+ δευτερόλεπτα στο φύλλο εργασίας μου.
Η απενεργοποίηση της ανανέωσης της οθόνης και η εκ νέου ενεργοποίηση στο τέλος της μακροεντολής μειώνει αυτό σε 2 δευτερόλεπτα.
Κατάφερα να βρω άλλο ένα ενοχλητικό σφάλμα. Αυτόματη προσαρμογή του φύλλου εργασίας (πριν από τη διόρθωση των συγχωνευμένων περιοχών) και παραμόρφωσε αρκετές σειρές. Ορισμένα "Κανονικά" κελιά, τα οποία είχαν οριστεί σε αναδίπλωση, αυξήθηκε το ύψος τους και εμφανίζονταν ως γραμμή (ή δύο γραμμές) κειμένου με μια κενή σειρά κάτω από το κείμενο. Η αναζήτηση στο Διαδίκτυο έδειξε ότι προκαλείται από την αλλαγή της οθόνης του Excel για την προσαρμογή των γραμματοσειρών του εκτυπωτή. Βρήκα μια "εργασία", πρόσθεσα στη μακροεντολή:
Αυξήστε τα πλάτη των στηλών κατά ένα μικρό ποσοστό.
Αυτόματη προσαρμογή όλων των σειρών στο φύλλο εργασίας.
Πραγματοποιήστε διορθώσεις στο ύψος της σειράς για να προσαρμόσετε τις συγχωνευμένες περιοχές.
Επαναφέρετε το πλάτος της στήλης στα αρχικά μεγέθη.
Αυτό διορθώθηκε, οι κενές σειρές δεν εμφανίζονται πλέον!
Νόμιζα ότι όλα ήταν πλέον σωστά, αλλά στη συνέχεια ανακάλυψα ένα επιπλέον πρόβλημα. Εάν κλείσω το βιβλίο εργασίας και το ανοίξω ξανά, οι κενές σειρές επιστρέφουν ξανά. Κοίταξα το Αρχείο/Επιλογές και έψαξα στο Διαδίκτυο για μια μέθοδο αποτροπής της ενημέρωσης του βιβλίου εργασίας στην οθόνη κατά το κλείσιμο/άνοιγμα του βιβλίου εργασίας χωρίς επιτυχία. Έπρεπε να προσθέσω το Private Sub Workbook_Open() στην καρτέλα "ThisWorkbook" με μια κλήση για εκτέλεση της μακροεντολής όταν ανοίξει το βιβλίο εργασίας.
Επιλογή ρητή
Sub Look4Merged()
Dim WSN As String 'Worksheet Name
Dim sht As φύλλο εργασίας 'Χρησιμοποιήθηκε από το "Set"
Dim LastRow As Long 'Τελευταία σειρά σε όλες τις στήλες με δεδομένα
Dim LastRowCC As Long 'Τελευταία σειρά στην τρέχουσα στήλη με δεδομένα
Dim LastColumn As Integer 'Αριθμός τελευταίας στήλης σε όλες τις σειρές με δεδομένα
Dim CurrCol ως ακέραιος «Αριθμός τρέχουσας στήλης
Dim Letter As String 'Μετατροπή αριθμού CurrCol σε συμβολοσειρά
Dim ILLetter As String 'Ευρετήριο στήλη μία προς τα δεξιά της τελευταίας στήλης
Dim ICE ως String 'Κελί μία στήλη δεξιά & μία γραμμή κάτω από την περιοχή δεδομένων fpm. Χρησιμοποιείται για τον υπολογισμό του απαιτούμενου συγχωνευμένου ύψους
Dim Crow As Long 'Τρέχον αριθμός σειράς
Χειρισμός σφαλμάτων Dim TwN As Long
Dim TwD As String 'Χειρισμός σφαλμάτων
Dim Mgd Ως Boolean 'True/False έλεγχος εάν το κελί έχει συγχωνευθεί
Dim MgdCellAddr As String «Περιέχει συγχωνευμένο εύρος ως συμβολοσειρά
Dim MgdCellStart As String 'Start γράμμα συγχωνευμένου εύρους κελιών Χρησιμοποιείται π.χ. επιθεώρηση της στήλης B για συγχωνευμένα κελιά, αγνοήστε τυχόν συγχωνευμένα κελιά που ξεκινούν από τη στήλη A και εκτείνονται στη στήλη B (ήδη αξιολογήθηκαν)
Dim MgdCellStart1 Ως συμβολοσειρά που χρησιμοποιείται για τον υπολογισμό του MgdCellStart
Dim MgdCellStart2 Ως συμβολοσειρά που χρησιμοποιείται για τον υπολογισμό του MgdCellStart
Dim Old Height As Single 'Υπάρχον ύψος όλων των σειρών στο συγχωνευμένο εύρος
Dim P1 ως ακέραιος αριθμός βρόχου / δείκτης
Dim Old Width As Single 'Υπάρχον πλάτος κελιών στο συγχωνευμένο εύρος
Dim NewHight As Single 'Απαιτούμενο ύψος όλων των σειρών στο συγχωνευμένο εύρος. Ενημερώστε μεμονωμένες σειρές αναλογικά εάν υπερβαίνει το OldHeight
Dim C1 ως ακέραιος αριθμός στηλών βρόχου
Dim R1 As Long 'Loop Row count/point
Dim Tweak As Single 'Μικρή αύξηση στο πλάτος της στήλης για να ξεπεραστεί το πρόβλημα της κενής σειράς
Dim orRange As Range
Σε σφάλμα GoTo TomsHandler
Application.ScreenUpdating = False 'ΠΟΛΥ πιο γρήγορα 15 δευτερόλεπτα εάν η οθόνη ενημερωθεί μόνο 2 δευτερόλεπτα απενεργοποιημένη.
Tweak = 1.04 'Αυξήστε το πλάτος της στήλης κατά 4% πριν από την Αυτόματη προσαρμογή όλων των σειρών.
WSN = ActiveSheet.Name
Στήλες("A:A").EntireRow.Hidden = False
«Βρείτε την τελευταία ενεργή γραμμή και στήλη σε ολόκληρο το φύλλο εργασίας με δεδομένα
Με ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
Search Order:=xlByColumns, SearchDirection:=xlPrevious).Στήλη
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
Search Order:=xlByRows, SearchDirection:=xlPrevious).Σειρά
Τέλος με
CurrCol = LastColumn + 1 'δηλαδή στα δεξιά της τελευταίας στήλης
Αν CurrCol < 27 Τότε
ILetter = Chr$(CurrCol + 64) 'Στήλη ευρετηρίου
Αλλού
ILLetter = Chr$(Int((CurrCol - 1) / 26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) 'Στήλη ευρετηρίου εάν διψήφιο. δεν έχει ενοχλήσει το τριπλό γράμμα
End If
«Το Icell βρίσκεται δεξιά και κάτω από τα δεδομένα. Το κελί χρησιμοποιείται για τον υπολογισμό του ύψους που απαιτείται για την προσαρμογή του συγχωνευμένου εύρους
ICEll = ILetter & LastRow + 1
«Αυξήστε το πλάτος της στήλης κατά μικρή ποσότητα για να θεραπεύσετε το σφάλμα αναδίπλωσης κενών σειρών.
Εύρος ("A" & LastRow + 1). Επιλέξτε
Για C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Προσαρμόστε την «αύξηση του πλάτους της στήλης κατά μικρή ποσότητα για την αντιμετώπιση του σφάλματος
ActiveCell.Offset(0, 1).Range("A1").Επιλέξτε ' μετακινήστε ένα κελί δεξιά
Επόμενο
«Αυτόματη προσαρμογή σειρών (αγνοεί τις συγχωνευμένες σειρές) με πλάτος στήλης 4% επιπλέον για την αποφυγή σφαλμάτων κενών σειρών σε ορισμένες γραμμές αναδίπλωσης
Κελιά.Επιλογή
Selection.Rows.AutoFit
Σετ sht = Φύλλα εργασίας(WSN) 'απαιτείται για την εύρεση Τελευταία καταχώρηση στη στήλη με δεδομένα
Για CurrCol = 1 έως LastColumn
«μετατροπή του τρέχοντος αριθμού στήλης σε άλφα (είτε μονό είτε διπλό γράμμα)
Αν CurrCol < 27 Τότε
Γράμμα = Chr$(CurrCol + 64)
Αλλού
Γράμμα = Chr$(Int((CurrCol - 1) / 26) + 64)
Letter = Letter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
End If
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Σειρά 'εύρεση τελευταίας σειράς στην τρέχουσα στήλη
Για Crow = 1 To LastRowCC
Εύρος (Γράμμα & Κοράκι). Επιλέξτε
Mgd = ActiveCell.MergeCells 'Είναι κελί σε συγχωνευμένο εύρος
Αν Mgd = True Τότε 'Εάν Αληθές, τότε είναι
"Ποια είναι η διεύθυνση συγχωνευμένης περιοχής; εξάγετε μονοψήφιο/διψήφιο για την έναρξη του εύρους
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Mid(MgdCellAddr, 2, 1)
MgdCellStart2 = Mid(MgdCellAddr, 3, 1)
Αν MgdCellStart2 = "$" Τότε
MgdCellStart = MgdCellStart1
Αλλού
MgdCellStart = MgdCellStart1 & MgdCellStart2
End If
Αν MgdCellStart = Γράμμα Τότε 'Είναι συγχωνευμένο κελί πρώτη στήλη ίση με την τρέχουσα στήλη
Με Φύλλα (WSN)
Παλιό Πλάτος = 0
Set oRange = Range(MgdCellAddr) 'Ορισμός oRange σε συγχωνευμένο εύρος εντοπίστηκε
Για C1 = 1 Προς oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, oRange.Column + C1 - 1).ColumnWidth 'Συσσώρευση πλάτη στηλών για εύρος κελιών (με προσθήκη 4%)
Επόμενο
Παλαιό Ύψος = 0
Για R1 = 1 Προς oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRrow, oRange.Row + R1 - 1).RowHeight 'Συσσωρεύστε το ύψος της γραμμής για το εύρος των κελιών
Επόμενο
oRange.MergeCells = False
.Range(Letter & CRow).Copy Destination:=Range(ICEll) 'Αντιγράφει κείμενο ΚΑΙ μέγεθος γραμματοσειράς, όχι μόνο τιμές
.Range(ICEll).WrapText = True 'wrap ICEll
.Columns(ILetter).ColumnWidth = OldWidth 'αλλαγή του πλάτους της στήλης που περιέχει το ICEL για να μιμηθεί το υπάρχον εύρος
.Rows(LastRow + 1).EntireRow.AutoFit 'Αυτόματη προσαρμογή της σειράς ICEL, έτοιμη να μετρήσει το απαιτούμενο συγχωνευμένο ύψος
oRange.MergeCells = True 'Επαναφορά του συγχωνευμένου εύρους πίσω στο συγχωνευμένο
oRange.WrapText = True 'και αναδίπλωση
«Μετρήστε το απαιτούμενο ύψος για το συγχωνευμένο εύρος
NewHeight = .Rows(LastRow + 1).RowHeight
«Το νέο απαιτούμενο ύψος υπερβαίνει το παλαιό υπάρχον ύψος
Αν NewHeight > OldHeight Τότε
Για R1 = CROW To CRow + oRange.Rows.Count - 1
«Αυξήστε κάθε σειρά στο εύρος αναλογικά
Εύρος (ILetter & R1).RowHeight = Range(ILetter & R1).RowHeight * NewHeight / OldHeight
Επόμενο
Αλλού
'επαρκές δωμάτιο στο συγχωνευμένο κελί
End If
CRow = CRow + oRange.Rows.Count - 1 'άλλο στο εύρος πολλών σειρών, θα πέσει στη 2η σειρά του εύρους και θα επαναλάβει τον υπολογισμό όταν φτάσετε στο "Επόμενο"
.Range(ICEll).Διαγράψτε το 'Zap ICEll έτοιμο για επόμενο υπολογισμό
.Range(ICEll).ColumnWidth = 8.1 'Ταξινόμηση του πλάτους της στήλης
Τέλος με
End If
End If
Επόμενο
Επόμενο
«Επαναφορά πλάτους στήλης αφαιρώντας το 4% προστέθηκε (απαιτείται για την αντιμετώπιση του σφάλματος αναδίπλωσης)
Εύρος ("A" & LastRow + 1). Επιλέξτε
Για C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak 'μείωση του πλάτους της στήλης στο αρχικό
ActiveCell.Offset(0, 1).Range("A1").Επιλέξτε ένα κελί δεξιά
Επόμενο
Εύρος ("A1"). Επιλέξτε
Application.ScreenUpdating = Αληθινή ενεργοποίηση της ενημέρωσης με διακόπτη
Έξοδος Sub
TomsHandler:
Application.ScreenUpdating = Αληθινή ενεργοποίηση της ενημέρωσης με διακόπτη
TwN = Σφάλμα.Αριθμός
TwD = Σφάλμα.Περιγραφή
MsgBox "Χρειάζεται να χειριστεί το σφάλμα " & TwN & " " & TwD
στάση
Συνέχιση
Sub End
Είναι δυνατόν να αποτραπεί το Excel από το να αλλάξει την εμφάνιση της οθόνης κατά το κλείσιμο/άνοιγμα του βιβλίου εργασίας;
1) Θα έπρεπε να αναγνωρίσω και να πληκτρολογήσω με μη αυτόματο τρόπο τις 160 συγχωνευμένες περιοχές.
Πρόσθεσα μια αναζήτηση για συγχωνευμένες περιοχές κελιών.
2) Χρησιμοποιεί τη σειρά πρώτη για να κάνει υπολογισμούς συγχωνευμένων κελιών (Κελί ZZ1). Χρησιμοποιώ μια πολύ μεγαλύτερη γραμματοσειρά στο κελί A1 (Τίτλος) που έχει ως αποτέλεσμα σφάλματα στον υπολογισμό του απαιτούμενου ύψους αυτόματης προσαρμογής.
Χρησιμοποιώ ένα κελί 1 στήλη δεξιά και 1 γραμμή κάτω από τα δεδομένα. (Ctrl+Shift+End, δεν βρίσκει αυτό το κελί)
3) Υπολογίζει εκ νέου όλα τα συγχωνευμένα κελιά, επομένως μείωσε το ύψος δύο σειρών που περιέχουν συγχωνευμένα και κανονικά κελιά κάνοντας τα κανονικά κελιά μη αναγνώσιμα.
Αλλάζω το ύψος της σειράς μόνο όταν το απαιτούμενο συγχωνευμένο ύψος υπερβαίνει το υπάρχον ύψος.
4) Η μέθοδος για την αντιγραφή δεδομένων σε συγχωνευμένες περιοχές στο κελί ZZ1 είναι εσφαλμένη, βασίζεται μόνο στο κείμενο στη συγχωνευμένη περιοχή, αλλά δεν λαμβάνει υπόψη τα διαφορετικά μεγέθη γραμματοσειράς σε διάφορα συγχωνευμένα κελιά.
Διόρθωσα τη μέθοδο αντιγραφής.
5) Η μακροεντολή είναι αργή: περίπου 15+ δευτερόλεπτα στο φύλλο εργασίας μου.
Η απενεργοποίηση της ανανέωσης της οθόνης και η εκ νέου ενεργοποίηση στο τέλος της μακροεντολής μειώνει αυτό σε 2 δευτερόλεπτα.
Κατάφερα να βρω άλλο ένα ενοχλητικό σφάλμα. Αυτόματη προσαρμογή του φύλλου εργασίας (πριν από τη διόρθωση των συγχωνευμένων περιοχών) και παραμόρφωσε αρκετές σειρές. Ορισμένα "Κανονικά" κελιά, τα οποία είχαν οριστεί σε αναδίπλωση, αυξήθηκε το ύψος τους και εμφανίζονταν ως γραμμή (ή δύο γραμμές) κειμένου με μια κενή σειρά κάτω από το κείμενο. Η αναζήτηση στο Διαδίκτυο έδειξε ότι προκαλείται από την αλλαγή της οθόνης του Excel για την προσαρμογή των γραμματοσειρών του εκτυπωτή. Βρήκα μια "εργασία", πρόσθεσα στη μακροεντολή:
Αυξήστε τα πλάτη των στηλών κατά ένα μικρό ποσοστό.
Αυτόματη προσαρμογή όλων των σειρών στο φύλλο εργασίας.
Πραγματοποιήστε διορθώσεις στο ύψος της σειράς για να προσαρμόσετε τις συγχωνευμένες περιοχές.
Επαναφέρετε το πλάτος της στήλης στα αρχικά μεγέθη.
Αυτό διορθώθηκε, οι κενές σειρές δεν εμφανίζονται πλέον!
Νόμιζα ότι όλα ήταν πλέον σωστά, αλλά στη συνέχεια ανακάλυψα ένα επιπλέον πρόβλημα. Εάν κλείσω το βιβλίο εργασίας και το ανοίξω ξανά, οι κενές σειρές επιστρέφουν ξανά. Κοίταξα το Αρχείο/Επιλογές και έψαξα στο Διαδίκτυο για μια μέθοδο αποτροπής της ενημέρωσης του βιβλίου εργασίας στην οθόνη κατά το κλείσιμο/άνοιγμα του βιβλίου εργασίας χωρίς επιτυχία. Έπρεπε να προσθέσω το Private Sub Workbook_Open() στην καρτέλα "ThisWorkbook" με μια κλήση για εκτέλεση της μακροεντολής όταν ανοίξει το βιβλίο εργασίας.
Επιλογή ρητή
Sub Look4Merged()
Dim WSN As String 'Worksheet Name
Dim sht As φύλλο εργασίας 'Χρησιμοποιήθηκε από το "Set"
Dim LastRow As Long 'Τελευταία σειρά σε όλες τις στήλες με δεδομένα
Dim LastRowCC As Long 'Τελευταία σειρά στην τρέχουσα στήλη με δεδομένα
Dim LastColumn As Integer 'Αριθμός τελευταίας στήλης σε όλες τις σειρές με δεδομένα
Dim CurrCol ως ακέραιος «Αριθμός τρέχουσας στήλης
Dim Letter As String 'Μετατροπή αριθμού CurrCol σε συμβολοσειρά
Dim ILLetter As String 'Ευρετήριο στήλη μία προς τα δεξιά της τελευταίας στήλης
Dim ICE ως String 'Κελί μία στήλη δεξιά & μία γραμμή κάτω από την περιοχή δεδομένων fpm. Χρησιμοποιείται για τον υπολογισμό του απαιτούμενου συγχωνευμένου ύψους
Dim Crow As Long 'Τρέχον αριθμός σειράς
Χειρισμός σφαλμάτων Dim TwN As Long
Dim TwD As String 'Χειρισμός σφαλμάτων
Dim Mgd Ως Boolean 'True/False έλεγχος εάν το κελί έχει συγχωνευθεί
Dim MgdCellAddr As String «Περιέχει συγχωνευμένο εύρος ως συμβολοσειρά
Dim MgdCellStart As String 'Start γράμμα συγχωνευμένου εύρους κελιών Χρησιμοποιείται π.χ. επιθεώρηση της στήλης B για συγχωνευμένα κελιά, αγνοήστε τυχόν συγχωνευμένα κελιά που ξεκινούν από τη στήλη A και εκτείνονται στη στήλη B (ήδη αξιολογήθηκαν)
Dim MgdCellStart1 Ως συμβολοσειρά που χρησιμοποιείται για τον υπολογισμό του MgdCellStart
Dim MgdCellStart2 Ως συμβολοσειρά που χρησιμοποιείται για τον υπολογισμό του MgdCellStart
Dim Old Height As Single 'Υπάρχον ύψος όλων των σειρών στο συγχωνευμένο εύρος
Dim P1 ως ακέραιος αριθμός βρόχου / δείκτης
Dim Old Width As Single 'Υπάρχον πλάτος κελιών στο συγχωνευμένο εύρος
Dim NewHight As Single 'Απαιτούμενο ύψος όλων των σειρών στο συγχωνευμένο εύρος. Ενημερώστε μεμονωμένες σειρές αναλογικά εάν υπερβαίνει το OldHeight
Dim C1 ως ακέραιος αριθμός στηλών βρόχου
Dim R1 As Long 'Loop Row count/point
Dim Tweak As Single 'Μικρή αύξηση στο πλάτος της στήλης για να ξεπεραστεί το πρόβλημα της κενής σειράς
Dim orRange As Range
Σε σφάλμα GoTo TomsHandler
Application.ScreenUpdating = False 'ΠΟΛΥ πιο γρήγορα 15 δευτερόλεπτα εάν η οθόνη ενημερωθεί μόνο 2 δευτερόλεπτα απενεργοποιημένη.
Tweak = 1.04 'Αυξήστε το πλάτος της στήλης κατά 4% πριν από την Αυτόματη προσαρμογή όλων των σειρών.
WSN = ActiveSheet.Name
Στήλες("A:A").EntireRow.Hidden = False
«Βρείτε την τελευταία ενεργή γραμμή και στήλη σε ολόκληρο το φύλλο εργασίας με δεδομένα
Με ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
Search Order:=xlByColumns, SearchDirection:=xlPrevious).Στήλη
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
Search Order:=xlByRows, SearchDirection:=xlPrevious).Σειρά
Τέλος με
CurrCol = LastColumn + 1 'δηλαδή στα δεξιά της τελευταίας στήλης
Αν CurrCol < 27 Τότε
ILetter = Chr$(CurrCol + 64) 'Στήλη ευρετηρίου
Αλλού
ILLetter = Chr$(Int((CurrCol - 1) / 26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) 'Στήλη ευρετηρίου εάν διψήφιο. δεν έχει ενοχλήσει το τριπλό γράμμα
End If
«Το Icell βρίσκεται δεξιά και κάτω από τα δεδομένα. Το κελί χρησιμοποιείται για τον υπολογισμό του ύψους που απαιτείται για την προσαρμογή του συγχωνευμένου εύρους
ICEll = ILetter & LastRow + 1
«Αυξήστε το πλάτος της στήλης κατά μικρή ποσότητα για να θεραπεύσετε το σφάλμα αναδίπλωσης κενών σειρών.
Εύρος ("A" & LastRow + 1). Επιλέξτε
Για C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Προσαρμόστε την «αύξηση του πλάτους της στήλης κατά μικρή ποσότητα για την αντιμετώπιση του σφάλματος
ActiveCell.Offset(0, 1).Range("A1").Επιλέξτε ' μετακινήστε ένα κελί δεξιά
Επόμενο
«Αυτόματη προσαρμογή σειρών (αγνοεί τις συγχωνευμένες σειρές) με πλάτος στήλης 4% επιπλέον για την αποφυγή σφαλμάτων κενών σειρών σε ορισμένες γραμμές αναδίπλωσης
Κελιά.Επιλογή
Selection.Rows.AutoFit
Σετ sht = Φύλλα εργασίας(WSN) 'απαιτείται για την εύρεση Τελευταία καταχώρηση στη στήλη με δεδομένα
Για CurrCol = 1 έως LastColumn
«μετατροπή του τρέχοντος αριθμού στήλης σε άλφα (είτε μονό είτε διπλό γράμμα)
Αν CurrCol < 27 Τότε
Γράμμα = Chr$(CurrCol + 64)
Αλλού
Γράμμα = Chr$(Int((CurrCol - 1) / 26) + 64)
Letter = Letter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
End If
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Σειρά 'εύρεση τελευταίας σειράς στην τρέχουσα στήλη
Για Crow = 1 To LastRowCC
Εύρος (Γράμμα & Κοράκι). Επιλέξτε
Mgd = ActiveCell.MergeCells 'Είναι κελί σε συγχωνευμένο εύρος
Αν Mgd = True Τότε 'Εάν Αληθές, τότε είναι
"Ποια είναι η διεύθυνση συγχωνευμένης περιοχής; εξάγετε μονοψήφιο/διψήφιο για την έναρξη του εύρους
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Mid(MgdCellAddr, 2, 1)
MgdCellStart2 = Mid(MgdCellAddr, 3, 1)
Αν MgdCellStart2 = "$" Τότε
MgdCellStart = MgdCellStart1
Αλλού
MgdCellStart = MgdCellStart1 & MgdCellStart2
End If
Αν MgdCellStart = Γράμμα Τότε 'Είναι συγχωνευμένο κελί πρώτη στήλη ίση με την τρέχουσα στήλη
Με Φύλλα (WSN)
Παλιό Πλάτος = 0
Set oRange = Range(MgdCellAddr) 'Ορισμός oRange σε συγχωνευμένο εύρος εντοπίστηκε
Για C1 = 1 Προς oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, oRange.Column + C1 - 1).ColumnWidth 'Συσσώρευση πλάτη στηλών για εύρος κελιών (με προσθήκη 4%)
Επόμενο
Παλαιό Ύψος = 0
Για R1 = 1 Προς oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRrow, oRange.Row + R1 - 1).RowHeight 'Συσσωρεύστε το ύψος της γραμμής για το εύρος των κελιών
Επόμενο
oRange.MergeCells = False
.Range(Letter & CRow).Copy Destination:=Range(ICEll) 'Αντιγράφει κείμενο ΚΑΙ μέγεθος γραμματοσειράς, όχι μόνο τιμές
.Range(ICEll).WrapText = True 'wrap ICEll
.Columns(ILetter).ColumnWidth = OldWidth 'αλλαγή του πλάτους της στήλης που περιέχει το ICEL για να μιμηθεί το υπάρχον εύρος
.Rows(LastRow + 1).EntireRow.AutoFit 'Αυτόματη προσαρμογή της σειράς ICEL, έτοιμη να μετρήσει το απαιτούμενο συγχωνευμένο ύψος
oRange.MergeCells = True 'Επαναφορά του συγχωνευμένου εύρους πίσω στο συγχωνευμένο
oRange.WrapText = True 'και αναδίπλωση
«Μετρήστε το απαιτούμενο ύψος για το συγχωνευμένο εύρος
NewHeight = .Rows(LastRow + 1).RowHeight
«Το νέο απαιτούμενο ύψος υπερβαίνει το παλαιό υπάρχον ύψος
Αν NewHeight > OldHeight Τότε
Για R1 = CROW To CRow + oRange.Rows.Count - 1
«Αυξήστε κάθε σειρά στο εύρος αναλογικά
Εύρος (ILetter & R1).RowHeight = Range(ILetter & R1).RowHeight * NewHeight / OldHeight
Επόμενο
Αλλού
'επαρκές δωμάτιο στο συγχωνευμένο κελί
End If
CRow = CRow + oRange.Rows.Count - 1 'άλλο στο εύρος πολλών σειρών, θα πέσει στη 2η σειρά του εύρους και θα επαναλάβει τον υπολογισμό όταν φτάσετε στο "Επόμενο"
.Range(ICEll).Διαγράψτε το 'Zap ICEll έτοιμο για επόμενο υπολογισμό
.Range(ICEll).ColumnWidth = 8.1 'Ταξινόμηση του πλάτους της στήλης
Τέλος με
End If
End If
Επόμενο
Επόμενο
«Επαναφορά πλάτους στήλης αφαιρώντας το 4% προστέθηκε (απαιτείται για την αντιμετώπιση του σφάλματος αναδίπλωσης)
Εύρος ("A" & LastRow + 1). Επιλέξτε
Για C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak 'μείωση του πλάτους της στήλης στο αρχικό
ActiveCell.Offset(0, 1).Range("A1").Επιλέξτε ένα κελί δεξιά
Επόμενο
Εύρος ("A1"). Επιλέξτε
Application.ScreenUpdating = Αληθινή ενεργοποίηση της ενημέρωσης με διακόπτη
Έξοδος Sub
TomsHandler:
Application.ScreenUpdating = Αληθινή ενεργοποίηση της ενημέρωσης με διακόπτη
TwN = Σφάλμα.Αριθμός
TwD = Σφάλμα.Περιγραφή
MsgBox "Χρειάζεται να χειριστεί το σφάλμα " & TwN & " " & TwD
στάση
Συνέχιση
Sub End
Είναι δυνατόν να αποτραπεί το Excel από το να αλλάξει την εμφάνιση της οθόνης κατά το κλείσιμο/άνοιγμα του βιβλίου εργασίας;