Οργάνωση των αρχείων του υπολογιστή σας μέσα από το excel

Λίγο φιλόδοξος ο τίτλος, αλλά οι τέσσερις μακροεντολές πού ακολουθούν ίσως σας βοηθήσουν να οργανώσετε τα αρχεία του δίσκου (ή των δίσκων) του υπολογιστή σας και να έχετε εύκολη πρόσβαση σε αυτά

Τρέξτε την πρώτη μακροεντολή: MakeFilesList, από ένα νέο καθαρό φύλλο excel. Όταν την τρέξετε, ανοίγει το γνωστό παράθυρο αναζήτησης και επιλογής αρχείων.

OrganizeFilesMacro1
Αναζητήστε και επιλέξτε τα αρχεία που σας ενδιαφέρουν, πατήσετε OK και στο φύλλο του excel θα περάσουν οι πλήρεις διαδρομές, τα ονόματα, και οι επεκτάσεις (extensions) των αρχείων που επιλέξατε στις στήλες D, C και B αντίστοιχα. (Ονόματα φακέλων, ακόμα και αν επιλεγούν, δεν θα εισαχθούν στο φύλλο).

OrganizeFilesMacro1_b
Ξ ανακαλέστε τη μάκρο για να επιλέξετε νέα αρχεία σε άλλους φακέλους ή δίσκους. Κάθε νέα επιλογή θα προστίθεται στη λίστα και στο τέλος θα έχετε μια όσο μεγάλη βάση των αρχείων σας θέλετε. Μπορείτε να ταξινομήσετε τη λίστα σας και να έχετε τα αρχεία σας κατά είδος, αλφαβητικά, κατά αποθηκευτικό μέσο κλπ.

OrganizeFilesMacro1_c
Με τη δεύτερη μακροεντολή: GoToFolder, μπορείτε να έχετε άμεση προσπέλαση στους φακέλους των αρχείων της λίστας. Επιλέξτε την πλήρη διαδρομή (στήλη D) ενός αρχείου, τρέξτε την μάκρο και θα ανοίξει ο φάκελος που περιέχει το αρχείο. Από εκεί μπορείτε να ανοίξετε το αρχείο, να το μετακινήσετε, να το διαγράψετε ίσως, ή απλώς να μετακινηθείτε σε άλλο φάκελο ή μέσο.

Η τρίτη μάκρο: MakeHyperlink δημιουργεί για το επιλεγμένο από την πλήρη διαδρομή του αρχείο (στήλη D), υπερσύνδεση προς το αρχείο αυτό. Έτσι, ακολουθώντας την σύνδεση, ανοίγετε άμεσα το αρχείο.

OrganizeFilesMacro3
Με την τέταρτη μακροεντολή: InsertPictureInCell, για τα αρχεία εικόνων και μόνον για αυτά, μπορείτε να εμφανίσετε στα κελιά της στήλης A ένα μικρό αντίγραφο της εικόνας. Επιλέξτε την πλήρη διαδρομή του αρχείου εικόνας (στήλη D), τρέξτε την μάκρο και η εικόνα θα εισαχθεί στο αντίστοιχο κελί της στήλης Α.

OrganizeFilesMakro4
Στον κώδικα των τεσσάρων μακροεντολών που ακολουθεί, θα βρείτε και οδηγίες για να αλλάξετε, αν θέλετε, τις στήλες όπου θα εμφανίζονται τα δεδομένα των αρχείων.


'*********************************************************
'Οργάνωση των αρχείων του υπολογιστή σας μέσα από το excel
'*********************************************************
'
' *** από το Excel Λύσεις ***
'
'Στην 1η Στήλη (στήλη "Α"), θα εμφανίζονται οι εικόνες.
'Στην 2η Στήλη (στήλη "Β"), θα εμφανίζονται τα extensions (επεκτάσεις, επιθέματα) των αρχείων.
'Στην 3η Στήλη (στήλη "C"), θα εμφανίζονται τα ονόματα των αρχείων.
'Στην 4η Στήλη (στήλη "D"), θα εμφανίζονται οι πλήρεις διαδρομές των αρχείων.
'Οι παρακάτω σταθερές 1,2,3,4 καθορίζουν τις στήλες αυτές αντίστοιχα. Αλλάξτε, αν θέλετε,
'τους αριθμούς αυτούς, άρα και τις στήλες, κατά τις ανάγκες σας.
'
Private Const PhotoColumn As Integer = 1
Private Const ExtensionColumn As Integer = 2
Private Const FileNameColumn As Integer = 3
Private Const FullPathColumn As Integer = 4
Private Const msg As String = "Επιλέξτε την πλήρη διαδρομή του αρχείου στη στήλη: " & FullPathColumn
Private Const msgFoto As String = "Δεν είναι αρχείο εικόνας"

Sub MakeFilesList()
Dim Folder As FileDialog
Dim SelectFile As Variant
Dim LastRow As Long
LastRow = Cells(Rows.Count, FullPathColumn).End(xlUp).Row
Set Folder = Application.FileDialog(msoFileDialogFilePicker)
With Folder
 .AllowMultiSelect = True
 If .Show = -1 Then
 For Each SelectFile In .SelectedItems
 LastRow = LastRow + 1
 Cells(LastRow, ExtensionColumn) = LastSplit(SelectFile, ".")
 Cells(LastRow, FileNameColumn) = Dir(SelectFile)
 If Dir(SelectFile) = "" Or VBA.InStr(1, Dir(SelectFile), "?") Then
 Cells(LastRow, FileNameColumn) = LastSplit(SelectFile, "\")
 End If
 Cells(LastRow, FullPathColumn) = SelectFile
 Next
 Else
 End If
End With
Set Folder = Nothing
End Sub

Sub GoToFolder()
On Error GoTo telos:
Dim SelectedFile As String
Dim LastRow As Long
Dim HypRng As Range
LastRow = Cells(Rows.Count, FullPathColumn).End(xlUp).Row
Set HypRng = Range(Cells(1, FullPathColumn), Cells(LastRow, FullPathColumn))
If Intersect(ActiveCell, HypRng) Is Nothing Then MsgBox msg: GoTo telos
HypRng.Hyperlinks.Delete
SelectedFile = Replace(ActiveCell.Value, Cells(ActiveCell.Row, FileNameColumn).Value, "")
With ActiveSheet
.Hyperlinks.Add .Range(ActiveCell.Address), SelectedFile
End With
ActiveCell.Hyperlinks(1).Follow NewWindow:=True
HypRng.Hyperlinks.Delete
telos:
End Sub

Sub MakeHyperlink()
Dim LastRow As Long
Dim HypRng As Range
LastRow = Cells(Rows.Count, FullPathColumn).End(xlUp).Row
Set HypRng = Range(Cells(1, FullPathColumn), Cells(LastRow, FullPathColumn))
If Intersect(ActiveCell, HypRng) Is Nothing Then MsgBox msg: GoTo telos
HypRng.Hyperlinks.Delete
With ActiveSheet
.Hyperlinks.Add .Range(ActiveCell.Address), ActiveCell.Value
End With
telos:
End Sub

Sub InsertPictureInCell()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim HypRow As Range
Dim keli As Range
Dim path As String
Dim delta As Integer
Dim ObPict As Object
Dim LastRow As Double
Dim HypRng As Range
LastRow = Cells(Rows.Count, FullPathColumn).End(xlUp).Row
Set HypRng = Range(Cells(1, FullPathColumn), Cells(LastRow, FullPathColumn))
If Intersect(ActiveCell, HypRng) Is Nothing Then MsgBox msg: GoTo telos
Set keli = Cells(ActiveCell.Row, PhotoColumn)
delta = FullPathColumn - PhotoColumn + 1
path = keli.Item(1, delta)
On Error Resume Next
Set ObPict = ActiveSheet.Pictures.Insert(path)
If ObPict Is Nothing Then MsgBox msgFoto: GoTo telos
On Error GoTo 0
keli.RowHeight = 60
keli.ColumnWidth = 80 * (13 / 72)
With ObPict
.ShapeRange.LockAspectRatio = msoTrue
.Height = keli.Height
If Val(Application.Version) < 12 Then .Width = keli.Width
.Top = Rows(keli.Row).Top
.Left = Columns(keli.Column).Left
End With
telos:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Private Function LastSplit(ByVal Str As String, ByVal delimiter As String) As String
LastSplit = VBA.Split(Str, delimiter)(UBound(Split(Str, delimiter)))
End Function

 

Κατεβάστε αν θέλετε το excel βιβλίο: OrganizeFiles.xls . Περιέχει όλο τον παραπάνω κώδικα και είναι έτοιμο να το χρησιμοποιήσετε.

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

9 Responses to Οργάνωση των αρχείων του υπολογιστή σας μέσα από το excel

  1. Ο/Η Γιώργος λέει:

    Πολύ καλό και χρήσιμο. Αν το είχα μερικές ημέρες πρίν θα γλύτωνα κάμποση δουλειά, γιατί το dirprint (προγραμματάκι που εξάγει τα ονόματα αρχείων και φακέλων) δεν είναι πάντα τόσο εύχρηστο. Μόνο μια παρατήρηση: Νομίζω οτι θα ήταν πιό χρήσιμο να μην περιέχεται η κατάληξη αρχείου (πχ .doc) στο όνομά του, αφού αυτό έχει ήδη περιγραφεί στην προηγούμενη στήλη. Αυτό για την περίπτωση που θέλει κάποιος μόνο το όνομα και μιας και είναι πιό εύκολο να συνθέσεις το πλήρες όνομα με την κατάληξη, παρά να το εξάγεις. Λεπτομέρειες. Ευχαριστώ πολύ.

  2. Ο/Η vioannis λέει:

    Γιώργο, μια γρήγορη λύση για αυτό που ζήτησες
    Αντικατέστησε την πρώτη μακροεντολή με την παρακάτω :

    Sub MakeFilesList()
    Dim Folder As FileDialog
    Dim SelectFile As Variant
    Dim LastRow As Long
    Dim FullName As String
    LastRow = Cells(Rows.Count, FullPathColumn).End(xlUp).Row
    Set Folder = Application.FileDialog(msoFileDialogFilePicker)
    With Folder
        .AllowMultiSelect = True
        If .Show = -1 Then
        For Each SelectFile In .SelectedItems
            LastRow = LastRow + 1
            Cells(LastRow, ExtensionColumn) = LastSplit(SelectFile, ".")
            FullName = Dir(SelectFile)
                If Dir(SelectFile) = "" Or VBA.InStr(1, Dir(SelectFile), "?") Then
                FullName = LastSplit(SelectFile, "\")
                End If
            Cells(LastRow, FileNameColumn).NumberFormat = "@"
            Cells(LastRow, FileNameColumn) = Replace(FullName, "." & LastSplit(SelectFile, "."), "")
            Cells(LastRow, FullPathColumn) = SelectFile
        Next
        Else
        End If
    End With
    Set Folder = Nothing
    End Sub
    
    
  3. Ο/Η Γιώργος λέει:

    Καλό και γρήγορο. Ευχαριστώ.

  4. Ο/Η Γιώργος λέει:

    Γιάννη γειά σου
    Επανέρχομαι μετά από καιρό στο θέμα: Όταν δημιουργούμε ένα φύλλο με υπερσυνδέσεις (με την κλασική διαδικασία «εισαγωγή υπερσύνδεσης») και θέλουμε να το διανείμουμε μαζί με τα αρχεία στα οποία παραπέμπουν οι υπερσυνδέσεις, δημιουργείται πρόβλημα. Δουλεύει μόνο αν το φύλλο excel βρίσκεται στον ίδιο φάκελο με τα αρχεία. Ακόμα όμως και στην περίπτωση αυτή, η υπερσύνδεση διατηρεί το πλήρες όνομα της προηγούμενης διαδρομής, πράγμα πολλές φορές ανεπιθύμητο. Επίσης διαπίστωσα ότι στο excel βιβλίο: OrganizeFiles.xls όταν τρέχεις την μακροεντολή «Υπερσύνδεση» δημιουργεί μια υπερσύνδεση αλλά καταργείται η προηγούμενη. Δηλαδή δεν μπορείς να έχεις υπερσυνδέσεις για όλα τα αρχεία σου. Πιθανόν να κάνω και λάθος;
    Υπάρχει λοιπόν λύση στο θέμα της διανομής ενός φύλλου-καταλόγου με παραπομπές σε αρχεία που ανοίγουν μέσα από την εφαρμογή τους και της εύκολης εγκατάστασης από τον παραλήπτη αυτού του καταλόγου;
    Ευχαριστώ πολύ.

  5. Ο/Η vioannis λέει:

    Γιώργο να έτσι είναι, όπως τα λες. Ακόμα και υπερσύνδεση μέσα στο ίδιο βιβλίο θα σπάσει αν αλλάξεις το όνομα του φύλλου. Αλλά για τέτοιες συνδέσεις έχω αναφέρει κάποιες λύσεις στο σημείωμα για τη συνάρτηση HYPERLINK. Η τοποθέτηση στον ίδιο φάκελο που προτείνεις είναι μία λύση. Για το άλλο θέμα του OrganizeFiles, αυτή ήταν η σκέψη μου όταν έγραφα τον κώδικα, η υπερσύνδεση να είναι πρόσκαιρη, για να μην βαραίνει το βιβλίο. Αν θες να το αλλάξεις, απλά στη Sub MakeHyperlink ακύρωσε τη γραμμή: HypRng.Hyperlinks.Delete

  6. Ο/Η Γιώργος λέει:

    Καλημέρα,
    Ευχαριστώ για την ανταπόκριση. Όλα καλά. Θα το ψάξω ακόμη.

  7. Ο/Η Alex Tologlou λέει:

    Καλημέρα κι ευχαριστώ για τις δεκάδες λύσεις που έχω βρει ψάχνοντας εδώ.
    Θα ήθελα να ρωτήσω αν υπάρχει τρόπος να γίνει μαζικά η μετατροπή της διαδρομής σε υπερσύνδεση, καθώς και η εισαγωγή μικρογραφιών.
    Το ρωτώ γιατί όταν έχεις ένα φύλλο με πολλές γραμμές, τα κουμπιά δεν ακολουθούν το scroll που κάνω και αναγκάζομαι κάθε 10-15 γραμμές να κάνω απόκρυψη

  8. Ο/Η vioannis λέει:

    Alex, Τα πλήκτρα που έχω στο παράδειγμα είναι για απλή επίδειξη του προγράμματος. Για συστηματική χρήση των μακροεντολών θα πρέπει να τις αντιστοιχίσεις σε κουμπιά στη ‘Γραμμή εργαλείων γρήγορης πρόσβασης’ ή σε πλήκτρα του πληκτρολογίου. (Υποθέτω ότι δουλεύεις σε excel 2007 και άνω, και περιγράφω για αυτά, όλα γίνονται σε όλα τα excel). Για το πρώτο δες εδώ:
    https://support.microsoft.com/en-us/kb/141689/el
    ή ίσως πιο καλά εδώ για το πρώτο και το δεύτερο.
    Για να αντιστοιχίσεις μια μάκρο σε πλήκτρο του πληκτρολογίου, στο γράφω και εγώ πιο απλά, πας: Μενού Προβολή, Μακροεντολές, Προβολή μακροεντολών, στο πλαίσιο που θα εμφανιστεί διαλέγεις την μακρο που θες (έστω την InsertPictureInCell), πατάς: Επιλογές και στο κουτάκι Πλήκτρο συντόμευσης γράψε ένα γράμμα αγγλικό, ας πούμε q, και πάτα ΟΚ. Τώρα για να καλείς τη μάκρο πάτα Cτrl +q ή αν έχεις βάλει κεφαλαίο γράμμα Cτrl +Shift+Q.
    Η δυνατότητα, μόνο η επιλεγμένη διαδρομή να γίνεται υπερσύνδεση είναι επιλογή του προγράμματος, για να μην βαραίνει το βιβλίο και δεν αλλάζει. Δεν είναι αδυναμία είναι ευελιξία.

  9. Ο/Η Αλέξανδρος λέει:

    Ευχαριστώ για την απάντηση, δεν είχα σκεφτεί ότι θα βαραίνει το βιβλίο

Τα σχόλια είναι απενεργοποιημένα.