Αναδίπλωση γραμμών πριν την εκτύπωση

Πρόκειται να εκτυπώσετε ένα φύλλο excel που επεκτείνεται σε πολλές στήλες. Έχετε ορίσει την εκτύπωση σε οριζόντια, έχετε μηδενίσει τα περιθώρια, έχετε ορίσει το μικρότερο δυνατό μέγεθος γραμματοσειράς και ρυθμίσατε όσο γίνεται πιο χαμηλά το ποσοστό στην διαμόρφωση σελίδας, ώστε να έχετε τελικά μία αναγνώσιμη εκτύπωση. Αλλά και πάλι τα 29,7 cm του Α4 χαρτιού δεν χωράνε όλες τις στήλες! Αυτό το πρόβλημα έθεσε πριν λίγες ημέρες στο ιστολόγιο ο Δημήτρης , και ταυτόχρονα πρότεινε την εξής λύση: Τα δεδομένα του προς εκτύπωση φύλλου, να πηγαίνουν σε ένα νέο φύλλο, και εκεί κάθε σειρά να αναδιπλώνεται και να γίνεται δύο σειρές. Η εκτύπωση θα γίνει από το νέο φύλλο και έτσι το συνολικό οριζόντιο μήκος της εκτύπωσης θα μειωθεί στο μισό.

Πρίν

Πρίν

Μετά

Μετά

Αυτό αναλαμβάνει να κάνει αυτόματα για σας η παρακάτω μακροεντολή. Επιλέγετε το κείμενο που είναι για εκτύπωση και την τρέχετε. Η μακροεντολή μετράει τη πλήθος των στηλών και με ένα input box προτείνει την αναδίπλωση στο μέσο περίπου, αλλά αυτό μπορείτε να το αλλάξετε κατά την κρίση σας επιλέγοντας οποία στήλη θέλετε από την οποία θα ξεκινήσει η αναδίπλωση.

anadiplosisInputBox
Μόλις επιλέξετε τη στήλη (αν δεν συμφωνείτε με την πρόταση του input box) και πατήσετε το OK, αμέσως μετά το φύλλο που δουλεύετε, θα προστεθεί ένα νέο φύλλο με το κείμενο που επιλέξατε αναδιπλωμένο εκεί ακριβώς που επιλέξατε. Στο νέο φύλλο μεταφέρονται οι αξίες (τιμές) και οι μορφοποιήσεις των κελιών του αρχικού. Για να ξεχωρίζουν οι εγγραφές μεταξύ τους στο νέο φύλλο, παρεμβάλλονται κενές σειρές. (Αν αυτό δεν το θέλετε τροποποιήστε την τρίτη από τις τρεις γραμμές του κώδικα: k = k + 1 σε k = k + 0). Η μακρο είναι κατάλληλη να φιλοξενηθεί είτε στο βιβλίο που σας ενδιαφέρει, είτε στο βιβλίο προσωπικών μακροεντολών. Θυμίζω ότι πριν τρέξετε τον κώδικα, πρέπει να έχετε επιλέξει όλη την περιοχή που θέλετε να εκτυπώσετε.
Ο κώδικας:

Sub NewSheetWithAnadiplosis()
Dim R As Range, anadiplosis As Range
Dim dpls As Integer
Dim i As Long, k As Long
Dim newSh As String
Dim S As Worksheet
If Not TypeName(Selection) = "Range" Then GoTo telos
Set R = Selection
If R.Count = 1 Then GoTo telos
Set S = R.Worksheet
On Error GoTo telos
Set anadiplosis = Application.InputBox _
    (prompt:="Επιλέξτε", _
    Title:="Επιλογή στήλης αναδίπλωσης", _
    Default:=R.Columns.EntireColumn(1 + Int(R.Columns.Count / 2)).Address, _
    Type:=8)
On Error GoTo 0
dpls = anadiplosis.Column
ActiveWorkbook.Sheets.Add after:=Worksheets(S.Name)
newSh = ActiveSheet.Name
Application.ScreenUpdating = False
For i = R.Row To R.Row + R.Rows.Count - 1
    k = k + 1
    Range(S.Cells(i, R.Column), S.Cells(i, dpls - 1)).Copy
    With Sheets(newSh).Cells(k, 1).End(xlToLeft)
         .PasteSpecial xlPasteFormats
         .PasteSpecial xlPasteValues
    End With
    k = k + 1
    Range(S.Cells(i, dpls), S.Cells(i, R.Column + R.Columns.Count - 1)).Copy
    With Sheets(newSh).Cells(k, 1).End(xlToLeft)
         .PasteSpecial xlPasteFormats
         .PasteSpecial xlPasteValues
    End With
    k = k + 1 ''Δημιουργεί κενές σειρές
Next
Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = True
Range("A1").Select
telos:
End Sub

Κατεβάστε από εδώ ή από εδώ, ένα παράδειγμα για να δείτε την μακροεντολή στην πράξη.

This entry was posted in excel, Μακροεντολές, VBA and tagged , , , , . Bookmark the permalink.