Μικρό βοήθημα για αρχεία με πολλά φύλλα

Αν έχετε βιβλία excel με πολλά φύλλα, ίσως θα θέλατε ένα βοήθημα για να τα οργανώνετε καλλίτερα και να τα χειρίζεστε πιο εύκολα. Η μακροεντολή, τον κώδικα της οποία θα βρείτε στο τέλος του σημειώματος, φιλοδοξεί να σας βοηθήσει. Είναι μία ρουτίνα γενικής χρήσης, κατάλληλη για το βιβλίο προσωπικών μακροεντολών αλλά και για το βιβλίο που σας ενδιαφέρει. Ανοίξτε λοιπόν, το πολύφυλλο βιβλίο σας και τρέξτε τη μάκρο MakeIndexSheet. Θα προστεθεί ένα νέο φύλλο με ετικέτα ‘Sheets Index’ όπως στην εικόνα:

manysheetshelper11
Στην πρώτη στήλη Α είναι ο κατάλογος όλων των φύλλων του βιβλίου. Ο κατάλογος εμφανίζει τα φύλλα με την σειρά που αυτά είναι στην γραμμή των φύλλων. Σημειώστε ότι η μάκρο σέβεται και δεν εμφανίζει στη λίστα, τα τυχόν κρυφά ή πολύ κρυφά φύλλα του βιβλίου. Στη δεύτερη στήλη Β έχουν δημιουργηθεί υπερσυνδέσεις, για άμεση μετάβαση στο φύλλο επιλογής σας. Ακόμα στο φύλλο ‘Sheets Index’ εμφανίζονται τρία κουμπιά. Επιλέξτε ένα από τα ονόματα των φύλλων στη στήλη Α και πατήστε το πλήκτρο ‘Εικόνα Φύλλου’. Θα εμφανιστεί η πάνω αριστερή εικόνα του φύλλου ή του γραφήματος που επιλέξατε. Ίσως αυτό σας βοηθήσει να θυμηθείτε τι περιέχει το φύλλο χωρίς να χρειαστεί να πάτε σ’ αυτό. Μπορείτε, από εδώ, να περιηγηθείτε σε όλα τα φύλλα του βιβλίου.

manysheetshelper22

manysheetshelper33
Με το πλήκτρο ‘Ταξινόμηση-Προσθήκη Νέων Φύλλων’ μπορείτε να ταξινομήσετε τα φύλλα του βιβλίου. Αντιγράψτε τη στήλη Α σε μία άλλη στήλη του φύλλου, ταξινομήστε με όποιο τρόπο θέλετε τη λίστα των φύλλων, αλφαβητικά ή με όποια σειρά εξυπηρετεί, προσθέστε ίσως νέα ονόματα φύλλων σε όποια θέση θέλετε, επιλέξτε τη νέα λίστα και πατήστε το πλήκτρο ‘Ταξινόμηση-Προσθήκη’. Στο παράδειγμα της εικόνας οι ετικέτες των φύλλων ταξινομήθηκαν στη στήλη D5:D25 και προστέθηκε ένα νέο φύλλο ‘Τηλέφωνα’:

manysheetshelper44
Μόλις πατήθηκε το ΟΚ, οι ετικέτες στη γραμμή των φύλλων έδειχναν έτσι:

manysheetshelper55
Μπορείτε χρησιμοποιήσετε την ‘Ταξινόμηση-Προσθήκη’ για να ταξινομήσετε μερικά μόνο από τα φύλλα ή μόνο για να προσθέσετε νέα.
Όταν ολοκληρώσετε τις αλλαγές στο βιβλίο, με το πλήκτρο ‘Αναδημιουργία του Sheets Index’ ανανεώστε τη σελίδα περιεχομένων Sheets Index, ώστε να απεικονίζει τη νέα μορφή του βιβλίου σας, ή διαγράψτε το, όταν το χρειαστείτε ξανά, απλά τρέξτε τη μάκρο.
Η μακροεντολή τρέχει σε όλες τις εκδόσεις του excel. Έχει δοκιμαστεί σε 2000, 2003, 2007, 2010
Σημείωση: Ειδικά προς φύλλα γραφημάτων, το excel δεν δημιουργεί υπερσυνδέσεις. Σε ένα βιβλίο που περιέχει φύλλα γραφημάτων, πατήστε Ctrl+K για να εμφανιστεί το μενού ‘Εισαγωγή υπερσύνδεσης’ και επιλέξτε ‘Θέση μέσα στο έγγραφο’. Παρατηρήστε ότι στον κατάλογο των φύλλων που εμφανίζει το μενού, δεν υπάρχουν τα φύλλα γραφημάτων.

Ανοίξτε το πλαίσιο για να δείτε και να αντιγράψετε τον κώδικα:

Private Const IndexSheet As String = "Sheets Index"
Private Const exL As String = "Excel Λύσεις"
Private ObSh As Object

Sub MakeIndexSheet()
Dim flag As Boolean
Dim msgbx As Integer
Dim msg As String
msg = "Το φύλλο Sheets Index υπάρχει!" & Chr(10) & Chr(10) _
        & "Θέλετε να διαγραφτεί και να δημιουργηθεί νέο;"
flag = CheckSheetExist(IndexSheet)
If flag = False Then Call MakeIndexSheetFinal
If flag = True Then msgbx = MsgBox(msg, vbOKCancel, exL)
    If msgbx = vbOK Then
    If CountVisible(ActiveWorkbook) = 1 Then GoTo telos
    Application.DisplayAlerts = False
    Worksheets(IndexSheet).Delete
    Application.DisplayAlerts = True
    Call MakeIndexSheetFinal
    Else
    GoTo telos
End If
telos:
End Sub

Private Sub MakeIndexSheetFinal()
Dim k As Integer
Dim apos As String
apos = VBA.ChrW(39)
Worksheets.Add(Before:=Sheets(1)).Name = IndexSheet
Columns(1).NumberFormat = "@"
For Each ObSh In Sheets
If ObSh.Visible = xlSheetVisible Then
    k = k + 1
    Cells(k + 1, 1) = ObSh.Name
    If Not TypeName(ObSh) = "Chart" And Not TypeName(ObSh) = "DialogSheet" Then _
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(k + 1, 2), Address:="", _
    SubAddress:=apos & ObSh.Name & apos & "!A1", TextToDisplay:=ObSh.Name
End If
Next
Range("A:B").Columns.AutoFit
Rows("1:1").RowHeight = 40
Range("A2").Select
ActiveWindow.FreezePanes = True
ActiveSheet.Buttons.Add(Range("A1").Left, Range("A1").Top, 110, 35).Select
With Selection
    .Name = "ShowSheetsPicture"
    .Placement = xlMove
    .Characters.Text = "Εικόνα Φύλλου"
    .OnAction = "ShowSheetsPicture"
End With
ActiveSheet.Buttons.Add(Range("C1").Left, Range("C1").Top, 110, 35).Select
With Selection
    .Name = "SortByColumnAndAddSheets"
    .Placement = xlMove
    .Characters.Text = "Ταξινόμηση-Προσθήκη Νέων Φύλλων"
    .OnAction = "SortByColumnAndAddSheets"
End With
ActiveSheet.Buttons.Add(Range("G1").Left, Range("G1").Top, 130, 35).Select
With Selection
    .Name = "MakeIndexSheet"
    .Placement = xlMove
    .Characters.Text = "Αναδημιουργία του Sheets Index"
    .OnAction = "MakeIndexSheet"
End With

Cells(k + 3, "A").Select
End Sub

Sub ShowSheetsPicture()
Dim keli As Range
Dim boo As Boolean
Dim PicName As String
Dim Shapes
PicName = "οοNewPictureName"
Set keli = ActiveCell
Application.ScreenUpdating = False
On Error Resume Next
ActiveSheet.Shapes(PicName).Delete
Set ObSh = ActiveWorkbook.Sheets(keli.Text)
If Sheets(keli.Value).Name = "" Then
    ActiveSheet.Shapes(PicName).Delete
    GoTo telos
End If
On Error GoTo 0
Select Case TypeName(ObSh)
Case "DialogSheet": GoTo telos
Case "Chart"
    If Not ObSh.Visible = True Then GoTo telos
    ObSh.Select
    ActiveChart.ChartArea.Copy
    Sheets(IndexSheet).Select
    boo = True
Case Else
    ObSh.Range("A1:J20").CopyPicture Appearance:=xlScreen, Format:=xlPicture
End Select
With ActiveSheet
    .Cells(keli.Row, "C").Select
    .Paste
    .Shapes(.Shapes.Count + (Val(Application.Version) = 12) * (.DrawingObjects.Count - 1)).Name = PicName
    .Shapes(PicName).Line.DashStyle = msoLineSquareDot
    If boo = True Then
        .Shapes(PicName).Height = 260
        .Shapes(PicName).Width = 400
    End If
End With
keli.Select
telos:
Application.ScreenUpdating = False
End Sub

Sub SortByColumnAndAddSheets()
Dim i As Integer, j As Integer, k As Integer, pl As Integer
Dim Q As Range
Dim msg1 As String, msg2 As String
Dim m1 As Integer, m2 As Integer, m3 As Integer
Dim Harr() As String
msg1 = "Επιλέξτε τη στήλη με τα φύλλα:"
msg2 = "Τα ονόματα των φύλλων πρέπει" & Chr(10) _
        & "να είναι σε μία μόνο στήλη." & Chr(10) & Chr(10) _
        & "Δεν πρέπει να υπάρχουν άδεια κελιά" & Chr(10) _
        & "και διπλότυπα στη στήλη που επιλέξατε."

On Error GoTo telos
Set Q = Application.InputBox(Prompt:=msg1, Title:=exL, _
                Default:=Selection.Address, Type:=8)
On Error GoTo 0
pl = Q.Count
For i = 1 To pl
Q.Item(i) = ClearIllegalCharacters(Q.Item(i))
Next
m1 = Q.Columns.Count
m2 = Application.CountBlank(Q)
m3 = Application.Max(Application.CountIf(Q, Q))
If m1 > 1 Or m2 > 0 Or m3 > 1 Then MsgBox msg2: GoTo telos
Application.ScreenUpdating = False
For i = 1 To pl
If CheckSheetExist(Q.Item(i).Text) = False Then
ActiveWorkbook.Sheets.Add.Name = Q.Item(i).Text
End If
Next
'Δημιουργία πίνακα με τα πολύ κρυφά φύλλα και προσωρινή μετατροπή σε κρυφά.
'(η vba χειρίζεται διαφορετικά τα πολύ κρυφά φύλλα)
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).Visible = xlVeryHidden Then
k = k + 1
ReDim Preserve Harr(1 To k)
Harr(k) = ActiveWorkbook.Sheets(i).Name
ActiveWorkbook.Sheets(i).Visible = xlHidden
End If
Next
Sheets(Q.Item(1).Text).Move Before:=Sheets(1)
For i = 2 To pl
Sheets(Q.Item(i).Text).Move After:=Sheets(Q.Item(i - 1).Text)
Next
'Επαναφορά της ιδιότητας xlVeryHidden στα φύλλα που προσωρινά
'για τις ανάγκες της ταξινόμησης είχαν μετατραπεί σε xlHidden
For i = 1 To k
ActiveWorkbook.Sheets(Harr(i)).Visible = xlVeryHidden
Next i
telos:
If Not Q Is Nothing Then Sheets(Q.Parent.Name).Select: Q.Select
Application.ScreenUpdating = True
End Sub

Private Function CheckSheetExist(ByVal SheetName As String) As Boolean
On Error Resume Next
CheckSheetExist = (Sheets(SheetName).Name <> "")
On Error GoTo 0
End Function

Private Function ClearIllegalCharacters(ByVal SheetName As String) As String
Dim i As Integer
Dim IllChar As Variant
IllChar = Array(42, 47, 58, 63, 91, 92, 93)
SheetName = Application.Trim(SheetName)
For i = LBound(IllChar) To UBound(IllChar)
SheetName = Replace(SheetName, ChrW(IllChar(i)), "_")
Next i
ClearIllegalCharacters = SheetName
End Function

Private Function CountVisible(ByVal wb As Workbook) As Integer
Dim ws As Worksheet
Dim i As Integer
For Each ws In wb.Worksheets
i = i - ws.Visible
Next
CountVisible = i
End Function
This entry was posted in excel, Μακροεντολές, VBA and tagged , , , , . Bookmark the permalink.