[Tutorial VBA] Lavorare con due (o più) file

Stato
Chiusa ad ulteriori risposte.

ges

Excel/VBA Expert
Amministratore
21 Giugno 2015
29.395
1.865
Como
2011MAC 365WIN
982
Ciao a tutti,
vedo spesso richieste di utenti che vogliono copiare dati da altri file Excel oppure vogliono traferire su altri file dei dati che hanno nel file aperto o ancora vogliono cercare dei dati tra altri file.

A tale proposito ho pensato di creare una mini guida esemplificativa con alcuni passaggi che comunque sono sempre comuni quando si tratta di interagire con altri file.

Prendiamo in esame, per esempio, il caso che vogliamo prelevare da un altro file.

Chiamo l'altro file con il quale devo interagire "FileAltro".

Dichiaro le variabili

I due files (cioè le due cartelle Excel)
Codice:
Dim WK1 As Workbook
Dim WK2 As Workbook
I fogli con i quali voglio interagire
Codice:
Dim sh1 As Worksheet
Dim sh2 As Worksheet
L'altro file
Codice:
Dim FileAltro As String
Poniamo la condizione che l'altro file è chiuso.
A questo punto abbiamo varie possibilità per trovare l'altro file sul computer ed aprirlo: indicare il percorso oppure trovare il percorso tramite finestra di dialogo.

La prima scelta ci porta a scrivere il percorso esatto.
Per esempio, mettiamo che il file si chiama "esempio" ed è posizionato sul Desktop:
Codice:
Set WK2 = Workbooks.Open("C:\Users\Ges\Desktop\esempio.xlsx")
Può essere che l'altro file stia nella stessa directory del nostro file aperto (per esempio, stessa cartella), a questo punto potremo usare questa istruzione:
Codice:
Set WK1 = ThisWorkbook
Set WK2 = Workbooks.Open(WK1.Path & "\" & " esempio.xlsx ")
L'altra ipotesi è che vogliamo cercarlo noi usando la finestra di dialogo
Codice:
FileAltro = Application.GetOpenFilename
Potremmo scegliere di visualizzare solo i files Excel
Codice:
FileAltro = Application.GetOpenFilename("File Excel (*.xls), *.xls")
Impostiamo come riferimento alle variabile sh1 e sh2 i due fogli rispettivamente del nostro file e dell'atro file (mettiamo che si chiamino tutte e due "Foglio1").
Codice:
Set WK1 = ThisWorkbook
Set WK2 = Workbooks.Open(FileAltro)
     
Set sh1 = WK1.Worksheets("Foglio1")
Set sh2 = WK2.Worksheets("Foglio1")
A questo punto i due file sono aperti e le variabili assegnate possiamo fare quindi quello che vogliamo.

Esempio:

Copiare dal filealtro:
Codice:
sh2.Range("A1:D10").Copy
sh1.Range("A1").PasteSpecial Paste:=xlValues
Trasferire dei dati
Codice:
sh2.Range("A1") = sh1.Range("A1")
Ciclare un intervallo:
Codice:
  x = 1
            For i = 1 To 10
                If sh2.Range("A" & i) = "topolino" Then
                    sh1.Range("A" & x) = sh2.Range("A" & i)
                    x = x + 1
                End If
            Next i
ecc. ecc.

Finito il nostro lavoro possiamo salvare e chiudere il "FileAltro".
Codice:
WK2.Save
WK2.Close
Nel caso aprendo la finestra di dialogo c'è un "pentimento", cioè si vuole annullare la procedura, per evitare che il codice restante venga eseguito si può usare questa istruzione

Codice:
If FileAltro = "Falso" Then
            MsgBox "Operazione annullata!", vbOKOnly + vbInformation
            GoTo Chiudi
End If
Questo il codice completo che copia dal "FileAltro".
Codice:
Sub Copia_da_FileAltro()
    Dim WK1 As Workbook
    Dim WK2 As Workbook
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim FileAltro As String
    Application.ScreenUpdating = False
      
    FileAltro = Application.GetOpenFilename
    If FileAltro = "Falso" Then
        MsgBox "Operazione annullata!", vbOKOnly + vbInformation
        GoTo Chiudi
    End If
      
    Set WK1 = ThisWorkbook
    Set WK2 = Workbooks.Open(FileAltro)
      
    Set sh1 = WK1.Worksheets("Foglio1")
    Set sh2 = WK2.Worksheets("Foglio1")
      
    sh2.Range("A1:D10").Copy
    sh1.Range("A1").PasteSpecial Paste:=xlValues

    Application.CutCopyMode = False
    WK2.Close SaveChanges:=False

    Application.ScreenUpdating = True
Chiudi:
    Set sh2 = Nothing
    Set sh1 = Nothing
    Set WK1 = Nothing
    Set WK2 = Nothing
End Sub
Spero di essere stato chiaro e che questa mini guida possa essere utile a chi ha bisogno di interagire tra due o più files.

Se ho omesso qualcosa o fatto qualche errore ognuno è libero di segnalarlo ed eventualmente integrare.
 

ges

Excel/VBA Expert
Amministratore
21 Giugno 2015
29.395
1.865
Como
2011MAC 365WIN
982
INTERAGIRE CON PIU' FILES CONTENUTI IN UNA CARTELLA

Continuando la discussione su che riguarda l'interazione tra due o più files, vorrei considerare anche la condizione in cui due o più files sono nella stessa cartella e c'è bisogno di interagire con tutti questi files.

In base al codice postato sopra si dovrebbe interagire più volte con ogni singolo file, allora facendo una piccola modifica e integrazione è possibile con una sola macro agire con tutti i file trattandoli uno alla volta.

Il primo passo è indicare il percorso della cartella con i file interessati, in questo esempio utilizzo la proprietà Application.FileDialog(msoFileDialogFolderPicker)

Tale proprietà apre la finestra di dialogo per permette di scegliere una cartella.

Prima di aprire la finestra di dialogo tramite il metodo Show predispongo un messaggio (MsgBox) con cui chiedo di scegliere la cartella con i files.

La cartella viene scelta con un ciclo in In .SelectedItems

Codice:
Dim miaCartella
Dim fd As FileDialog
Dim fDialog As FileDialog

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

    MsgBox "Scegli la cartella con i files!", vbInformation, "AVVISO"

  With fDialog  
    .Show
    cartella = .SelectedItems(1)
Selezionata la cartella si dichiara il file dal quale si sta operando e il foglio interessato

Codice:
Set WK = ThisWorkbook
Set sh = WK.Worksheets(1)
Utilizzo CreateObject("Scripting.FileSystemObject")

Codice:
Set fs = CreateObject("Scripting.FileSystemObject")
che per una migliore spiegazione vi rimando al sito Ennius.altervista

Richiamo la cartella selezionata

Codice:
Set Fold = fs.getfolder(cartella)
Set Cartella = Fold.Files
E con un ciclo esamino tutti i files contenuti e il foglio (o i fogli)

Codice:
For Each Nomefile In Cartella
        Set WK1 = Workbooks.Open(Nomefile)
        Set sh1 = WK1.Worksheets(1)
A questo punto sono "in contatto" con ciascun file e il foglio (o i fogli) contenuti nella cartella e posso fare quello che voglio (copiare, modificare, cancellare, ecc.)

Alla fine salvo e chiudo

Codice:
WK1.Save
WK1.Close
Come esempio posto un codice che copia tutti i dati di ciascun file contenuto nel Foglio1 della cartella e li incolla uno sotto l'altro nel file dal quale opero.

ESEMPIO: Copiare fogli da più files messi una una cartella di Windows
Codice:
Sub Copia_piu_file_da_cartella()
    'by Ges - www.forumexcel.it
    Dim fDialog As FileDialog
    Dim uR As Long
    Dim uR1 As Long
    Dim WK As Workbook
    Dim WK1 As Workbook
    Dim sh As Worksheet
    Dim sh1 As Worksheet
    Dim fs As Object
    Dim Fold As String
    Dim myFold As Object
    Dim myFile As Object
    Dim myFiles As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    MsgBox "Scegli la cartella con i files!", vbInformation, "AVVISO"
    With fDialog
        If .Show = -1 Then
            Fold = .SelectedItems(1)
        Else
            MsgBox "Operazione annullata!", vbInformation
            Exit Sub
        End If
    End With
    Set WK = ThisWorkbook
    Set sh = WK.Worksheets(1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set myFold = fs.getfolder(Fold)
    Set myFiles = myFold.Files
    For Each myFile In myFiles
        Set WK1 = Workbooks.Open(myFile) ' si procede ad aprire ciascun file presente nella cartella selezionata
      
        '----------------------
        ' la procedura che segue copia l'intervallo in A:L di ciascun file e lo accoda in questo
        ' ma è solo un esempio perchè una volta che si apre ciascun file si può può gestire in molteplici modi
        '----------------------
        Set sh1 = WK1.Worksheets(1)
        uR = sh1.Cells(Rows.Count, 1).End(xlUp).Row
        sh1.Range("A1:L" & uR).Copy
        uR1 = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
        sh.Range("A" & uR1).PasteSpecial Paste:=xlValues
        '---------
      
        WK1.Close SaveChanges:=False
    Next
    WK.Save
    Set fs = Nothing
    Set myFold = Nothing
    Set fDialog = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Fatto!", vbInformation, "NOTIFICA"
End Sub

Altro ESEMPIO: Copiare fogli da più files messi una una cartella di Windows confrontando le intestazioni di colonna
Visual Basic:
Sub Copia_piu_file_da_cartella_confrontando_le_intestazioni_di_colonna()
    'by Ges - www.forumexcel.it
    Dim fDialog As FileDialog ' dichiaro le variabili
    Dim uR As Long
    Dim uR1 As Long
    Dim uC1 As Integer
    Dim uC As Integer
    Dim c As Integer
    Dim c1 As Integer
    Dim WK As Workbook
    Dim WK1 As Workbook
    Dim sh As Worksheet
    Dim sh1 As Worksheet
    Dim fs As Object
    Dim Fold As String
    Dim myFold As Object
    Dim myFile As Object
    Dim myFiles As Object
    Application.ScreenUpdating = False ' annullo lo sfarfallio dello schermo
    Application.DisplayAlerts = False ' annullo gli avvisi sullo schermo
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker) ' imposto una variabile per l'oggetto fDialog che mi serve per aprire una finestra di Windows
    MsgBox "Scegli la cartella con i files!", vbInformation, "AVVISO" ' un messaggio chiede di selezionare la cartella con i files dai quali si vogliono estrarre i dati
    With fDialog
        If .Show = -1 Then ' -1 è un controllo di Office e indica che l'utente ha scelto "OK"
            Fold = .SelectedItems(1) ' seleziona la cartella
        Else ' se l'utente non ha selezionato "Ok"
            MsgBox "Operazione annullata!", vbInformation ' se non si seleziona la cartella e si sceglie di annullare il codice si interrompe
            Exit Sub
        End If
    End With
    Set WK = ThisWorkbook ' questo file
    Set sh = WK.Worksheets(1) ' il foglio di questo file
    Set fs = CreateObject("Scripting.FileSystemObject") ' imposto una variabile per l'oggetto FileSystemObject
    On Error GoTo esci
    Set myFold = fs.getfolder(Fold) ' imposto una variabile oggetto erp identificare la cartella
    Set myFiles = myFold.Files ' imposto una variabile oggetto per i files della cartella
    For Each myFile In myFiles 'uso un ciclo per leggere tutti i files della cartella
        Select Case LCase(Right(myFile.Name, 4)) 'leggo le estensioni dei files
            Case ".xls", "xlsx", "xlsm" ' se sono file Excel
                Set WK1 = Workbooks.Open(myFile) ' apro il rpimo file trovato nella cartella
                For Each sh1 In WK1.Worksheets ' scorro tutti i fogli di ciascun file
                    uC1 = sh1.Cells(1, Columns.Count).End(xlToLeft).Column ' trovo l'ultima colonna avvalorata di ciascun foglio
                    uC = sh.Cells(1, Columns.Count).End(xlToLeft).Column ' trovo l'ultima colonna avvalorata del foglio di questo file
                    uR = sh.Cells.Find("*", SearchDirection:=xlPrevious).Row + 1 ' trovo la prima riga vuota del foglio di questo file
                    For c1 = 1 To uC1 ' uso un ciclo per leggere le intesatzioni di colonna del foglio dell'altro file
                        For c = 1 To uC ' uso un ciclo per leggere le intesatzioni di colonna del foglio di questo file
                            If Trim(sh1.Cells(1, c1)) = Trim(sh.Cells(1, c)) Then ' confronto le intestazioni di questo file e di ciascun file altro
                                uR1 = sh1.Cells(Rows.Count, c1).End(xlUp).Row ' trovo l'ultima riga piena della colonna che andrò a copiare
                                sh1.Range(sh1.Cells(2, c1), sh1.Cells(uR1, c1)).Copy 'copia la colonna trovata dell'altro file
                                sh.Cells(uR, c).PasteSpecial Paste:=xlValues ' incollo la colonna trovata in questo foglio
                            End If
                        Next c
                    Next c1
                Next sh1
                WK1.Close SaveChanges:=False ' chiudo l'altro file senza salvarlo
        End Select
    Next
    WK.Save ' salvo questo file
    Set fs = Nothing 'svuoto la memoria della variabile fs
    Set myFold = Nothing 'svuoto la memoria della variabile myFold
    Set fDialog = Nothing 'svuoto la memoria della variabile fDialog
    Application.ScreenUpdating = True ' ripristino lo sfarfallio
    Application.DisplayAlerts = True ' ripristino gli avvisi sullo schermo
    MsgBox "Operazione completata!", vbInformation, "NOTIFICA" ' un messaggio avvisa che il codice è stato eseguito
    Exit Sub ' esce dalla sub
esci:     'nel caso si verifica un errore ...
    MsgBox "Si è verificato un errore inatteso!" & vbCrLf & _
        "Possibili cause:" & vbCrLf & _
        "1) Si è premuto sul tasto 'OK' senza selezionare la cartella" & vbCrLf & _
        "2) I files nella cartella scelta sono illegibili e/o corrotti", vbExclamation, "ATTENZIONE" ' un messaggio avvisa che si è verificato un errore
End Sub
 

ges

Excel/VBA Expert
Amministratore
21 Giugno 2015
29.395
1.865
Como
2011MAC 365WIN
982
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
 

ges

Excel/VBA Expert
Amministratore
21 Giugno 2015
29.395
1.865
Como
2011MAC 365WIN
982
Aggiungo il codice per Combinare più Files Excel in più Fogli nello stesso File
Visual Basic:
Sub Combina_Files_In_Fogli()
    Dim myFiles As String
    Dim percorso As String
    Dim DestWB As Workbook
    Dim OrigWB As Workbook
    Dim fDialog As FileDialog
    Dim WS As Object
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If fDialog.Show = -1 Then
        percorso = fDialog.SelectedItems(1) & "\"
    Else
        MsgBox "Operazione annullata!", vbInformation
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        myFiles = Dir(percorso & "*.xl*")
        Set DestWB = ThisWorkbook
        Do While myFiles <> vbNullString
            Set OrigWB = Workbooks.Open(Filename:=percorso & myFiles, ReadOnly:=True)
            myFiles = Left(Left(myFiles, Len(myFiles) - 5), 29)
            For Each WS In OrigWB.Sheets
                WS.Copy after:=DestWB.Sheets(DestWB.Sheets.Count)
                If OrigWB.Sheets.Count > 1 Then
                    DestWB.Sheets(DestWB.Sheets.Count).Name = myFiles & WS.Index
                Else
                    DestWB.Sheets(DestWB.Sheets.Count).Name = myFiles
                End If
            Next WS
            OrigWB.Close SaveChanges:=False
            myFiles = Dir
        Loop
        DestWB.Sheets(1).Delete
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    MsgBox "FATTO!", , "NOTIFICA"
End Sub
 
Stato
Chiusa ad ulteriori risposte.

Sostieni ForumExcel

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