Creare collegamenti a files in Excel

Stato
Chiusa ad ulteriori risposte.

ges

Excel/VBA Expert
Amministratore
Expert
21 Giugno 2015
21.138
1.733
Como
2011MAC 2016WIN
449
Ciao a tutti,
un mio amico mi ha chiesto come creare con una macro dei collegamenti ipertestuali a dei files word e pdf in modo che possa averli elencati in una colonna di un foglio Excel.

All'inizio avevo pensato di fare scrivere tutti i nomi dei files in una colonna che poi li cercavo con una macro e nel caso i nomi corrispondevano si creava il collegamento.

Poi ho visto che potevo anche scrivere i nomi dei files nel foglio direttamente usando la macro, infine - per meglio agevolare il lavoro del mio amico - ho pensato di usare un file Excel come file-programma cioè che servisse solo a creare i collegamenti tra una cartella contenente dei files (WORD, PDF, JPEG ecc.) e un altro file Excel a scelta dell'utente.

Credendo di aver fatto un discreto lavoro, pubblico qui il tutto nell'auspicio che possa servire a qualcuno che debba fare lo stesso lavoro.

Questo il codice che ho usato:

Codice:
Option Explicit
Sub Inserisci_NomeFiles_Iperlink()
    Application.ScreenUpdating = False
    Dim fd As FileDialog
    Dim i As Integer
    Dim miaCartella
    Dim domanda As String
    Dim lunghezza As Integer
    Dim uR As Long
    Dim FileAltro As Variant
    Dim WK As Workbook
    Dim sh As Worksheet
    Dim fs As Object
    Dim Fold As Object
    Dim Nomefile As Object
    Dim Cartella As Object
    Dim colonna As String
    Dim riga As Integer
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    Dim CartellaSelezionata As Variant
    MsgBox "Scegli la cartella con i files ai quali attivare i collegamenti", vbInformation, "AVVISO"
    With fd
        If .Show = -1 Then
            i = 1
            For Each CartellaSelezionata In .SelectedItems
                miaCartella = CartellaSelezionata
            Next
        Else
            Exit Sub
        End If
    End With
    MsgBox "Scegli il file excel su cui copiare i collegamenti", vbInformation, "AVVISO"
    FileAltro = Application.GetOpenFilename
    If FileAltro = "Falso" Then
        MsgBox "Operazione annullata!", vbOKOnly + vbInformation
        Exit Sub
    End If
    Set WK = Workbooks.Open(FileAltro)
    Set sh = WK.Worksheets(1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set Fold = fs.getfolder(miaCartella)
    Set Cartella = Fold.Files
    domanda = InputBox("Scegli la cella iniziale per scrivere i collegamenti. (Esempio B2)")
    lunghezza = Len(domanda)
    For i = 1 To lunghezza
        If IsNumeric(Mid(domanda, i, 1)) = True Then
            Exit For
        End If
    Next i
    colonna = Left(domanda, i - 1)
    riga = Val(Replace(domanda, colonna, ""))
    On Error GoTo esci
    For Each Nomefile In Cartella
        While sh.Cells(riga, colonna).Value <> ""
            riga = riga + 1
        Wend
        DoEvents
        sh.Cells(riga, colonna) = Left(Nomefile.Name, InStr(Nomefile.Name, ".") - 1)
        ActiveSheet.Hyperlinks.Add Anchor:=sh.Cells(riga, colonna), Address:=Nomefile
    Next
    uR = sh.Cells(Rows.Count, colonna).End(xlUp).Row
    sh.Sort.SortFields.Clear
    sh.Sort.SortFields.Add Key:=Range(domanda & ":" & colonna & uR), Order:=xlAscending
    With sh.Sort
        .SetRange Range(domanda & ":" & colonna & uR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    WK.Save
    WK.Close
    MsgBox "Fatto!", vbInformation, "NOTIFICA"
    Set fs = Nothing
    Set Cartella = Nothing
    Set Fold = Nothing
    Set fd = Nothing
    Application.ScreenUpdating = True
    Exit Sub
esci:
    MsgBox "Si è verificato un errore, forse non hai digitato correttamente la cella scelta." & vbCrLf & "Ripeti l'operazione!", vbExclamation, "ATTENZIONE"
    WK.Save
    WK.Close
End Sub
In allegato il file-programma
 

Allegati

Ultima modifica:

rollis13

Utente assiduo
15 Novembre 2015
1.594
63
Cordenons
Office 2016 x64
81
Grazie per la condivisione, ma sii buono e ti vorranno bene molte persone Lingua_lingua, cambia questa macro in qualcosa così:
Codice:
Private Sub CommandButton3_Click()

    'Application.Quit
    Application.Visible = True
    ActiveWorkbook.Close
    
End Sub
 

ges

Excel/VBA Expert
Amministratore
Expert
21 Giugno 2015
21.138
1.733
Como
2011MAC 2016WIN
449
Ciao Rollis, visto che mi chiedi di essere buono Lingua_lingua farò di più oltre a cambiare la macro del pulsante di chiusura disabilito anche la X della UserForm, così:

Codice:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        Cancel = True
        MsgBox "Usare il pulsante CHIUDI per uscire", vbInformation, "NOTIFICA"
    End If
End Sub
Il file modificato lo rimetto sopra.
 
  • Like
Reactions: Andrea Guerri

ges

Excel/VBA Expert
Amministratore
Expert
21 Giugno 2015
21.138
1.733
Como
2011MAC 2016WIN
449
Aggiungo il codice per ottenere i collegamenti ipertestuali a dei files presenti in una cartella con più sottocartelle.
Questo codice va messo nella cartella in cui si vogliono ottenere gli Iperlink, si chiederà di selezionare la cartella con le altre sottocartelle contenenti i files che saranno riportati nel foglio attivo (colonna A, a partire da A1).
Visual Basic:
Sub IperlinkFilesFolders()
    Set folder = Application.FileDialog(msoFileDialogFolderPicker)
    If folder.Show <> -1 Then Exit Sub
    xDir = folder.SelectedItems(1)
    Call FilesFolder(xDir)
End Sub
Sub FilesFolder(ByVal FolderName As String)
    Dim FileSystemObject As Object
    Dim iFolder As Object
    Dim iSubFolder As Object
    Dim iFile As Object
    Dim esteFile As Variant
    Dim iRow As Long
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set iFolder = FileSystemObject.GetFolder(FolderName)
    For Each iFile In iFolder.Files
        iRow = 1
        While Cells(iRow, 1) <> ""
            iRow = iRow + 1
        Wend
        estFile = Split(iFile, "\")
        If Left(estFile(UBound(estFile)), 2) <> "._" Then
            Cells(iRow, 1) = estFile(UBound(estFile))
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(iRow, 1), Address:=iFile
            estFile = ""
        End If
    Next iFile
        For Each iSubFolder In iFolder.SubFolders
            FilesFolder iSubFolder.Path
        Next iSubFolder
    Set iFile = Nothing
    Set iFolder = Nothing
    Set FileSystemObject = Nothing
End Sub
 
Stato
Chiusa ad ulteriori risposte.

Sostieni ForumExcel

Aiutaci a sostenere le spese e a mantenere online la community attraverso una libera donazione!