Creare nuovo file excel estraendo i dati da altri file excel

Ciao Red Mud,

Parte l'estrazione, estrae TUTTI i dati nei file contenuti nella prima cartella, mi mostra l'avanzamento, ma NON PASSA ALLA SECONDA CARTELLA e alle successive.

Per replicare la tua struttura ho creato una directory C:\SCHEDE PREZZO. In questa cartella ho creato due sottodirectory, Pippo e Pluto, cioè: C:\SCHEDE PREZZO\Pippo e C:\SCHEDE PREZZO\Pluto. Nella  sottocartella C:\SCHEDE PREZZO\Pippo ho creato due file Test1.xlsx e Test2.xlsx. In modo analogo, nella sottocartella C:\SCHEDE PREZZO\Pluto  ho creato due file Test3.xls x e Test4.xlsx. Ognuno di questi file ha tre fogli: Foglio1, Foglio2 e Foglio3.

Ho poi eseguito la seguente versione, molto leggermente aggiornata, del mio codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim FSO As Object

    Dim oFile As Object

    Dim oFiles As Object

    Dim oFolder As Object

    Dim oSubFolder As Object

    Dim WB As Workbook

    Dim SH As Worksheet, destSH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim arrExclude As Variant, arrHeaders As Variant

    Dim iRow As Long

    Dim j As Long, k As Long

    Dim myFile As String, myFolder As String

    Dim Res As Variant

    Dim sPrompt As String, iButtons As Long, sTitle As String

    Const sAddress = "F2,K2,C4"

    Const sFolder As String = "**C:\SCHEDE PREZZO**"

    Const sHeaders As String = "File di Origine,Foglio di Origine,Cliente,Data,Descrizione"

    Set WB = ThisWorkbook

    Set destSH = WB.Sheets(1)

    iRow = 1

    arrExclude = VBA.Array("Calcolo peso", "Forme")

    arrHeaders = Split(sHeaders, ",")

    With destSH.Range("A1:E1")

        .Value = arrHeaders

        .Font.Bold = True

        .Font.Underline = True

    End With

    On Error GoTo XIT

    Application.ScreenUpdating = False

    Set FSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = FSO.GetFolder(sFolder)

    For Each oSubFolder In oFolder.SubFolders

        Set oFiles = oSubFolder.Files

        For Each oFile In oFiles

        Application.StatusBar = "Processing il file " & oFile.Path

            Set WB = Workbooks.Open(oFile)

            With WB

                For Each SH In WB.Worksheets

                    With SH

                        j = 1

                        Res = Application.Match(.Name, arrExclude, 0)

                        If IsError(Res) Then

                            iRow = iRow + 1

                            With destSH

                                .Cells(iRow, "A").Value = WB.FullName

                                .Cells(iRow, "B").Value = SH.Name

                                Set Rng = SH.Range(sAddress)

                                For Each rCell In Rng.Cells

                                    j = j + 1

                                    .Cells(iRow, j + 1).Value = rCell.Value

                                Next rCell

                            End With

                        End If

                    End With

                Next SH

                .Close savechanges:=False

            End With

        Next oFile

    Next oSubFolder

    destSH.UsedRange.EntireColumn.AutoFit

XIT:

    With Application

        .ScreenUpdating = True

        .StatusBar = False

    End With

    If Err.Number = 0 Then

        sPrompt = "La procedura è stata completata senza alcun problema"

        iButtons = 64

        sTitle = "Finito"

    Else

        sPrompt = "Errore " _

                & Err.Number _

                & " (" _

                & Err.Description _

                & ") nella routine: Tester"

        iButtons = 16

        sTitle = "ERRORE"

    End If

    Call MsgBox(sPrompt, iButtons, sTitle)

End Sub

'<<=========

Come risultato, ho ottenuto i seguenti dati:

File di Origine	Foglio di Origine	Cliente	Data	Descrizione
C:\SCHEDE PREZZO\Pippo\Test1.xlsx	Foglio1	100	01/01/2014	abc
C:\SCHEDE PREZZO\Pippo\Test1.xlsx	Foglio2	101	02/01/2014	abd
C:\SCHEDE PREZZO\Pippo\Test1.xlsx	Foglio3	102	03/01/2014	abe
C:\SCHEDE PREZZO\Pippo\Test2.xlsx	Foglio1	200	01/02/2014	bbc
C:\SCHEDE PREZZO\Pippo\Test2.xlsx	Foglio3	201	02/02/2014	bbd
C:\SCHEDE PREZZO\Pippo\Test2.xlsx	Foglio2	202	03/02/2014	bbe
C:\SCHEDE PREZZO\Pluto\Test3.xlsx	Foglio1	300	01/03/2014	cbc
C:\SCHEDE PREZZO\Pluto\Test3.xlsx	Foglio2	301	02/03/2014	cbd
C:\SCHEDE PREZZO\Pluto\Test3.xlsx	Foglio3	302	03/03/2014	cbe
C:\SCHEDE PREZZO\Pluto\Test4.xlsx	Foglio1	400	01/04/2014	dbc
C:\SCHEDE PREZZO\Pluto\Test4.xlsx	Foglio2	401	02/04/2014	dbd
C:\SCHEDE PREZZO\Pluto\Test4.xlsx	Foglio3	402	03/04/2014	dbe

A condizione che tu stia utilizzando una struttura di directory simile, sono convinto che dovresti ottenere risultati simili e, più in particolare, il codice suggerito dovrebbe aprire ogni cartella di lavoro in ciascuna delle sottodirectory della directory C:\SCHEDE PREZZO e dovrebbe copiare i dati di interesse sul foglio di riepilogo nel file  che contiene il codice.

Qualora volessi darmi il tuo indirizzo email posso inviarti il file.

 Sarei felice di farlo - e troverai un indirizzo email decifrabile se fai clic sul mio profilo - ma credo che il problema riguarda la struttura di directory e non credo che un singolo file possa essere di aiuto.

Se hai ancora un problema, forse potresti mandarmi una copia privata della struttura dei tuoi directory/file.

===

Regards,

Norman

Ciao Norman,

ti chiedo scusa.

Nell'esempio che ti ho postato sopra, ho ricostruito il percorso per evitare di scriverti in nome delle cartelle poiché ogni cartella ha il nome del cliente (per motivi di riservatezza volevo evitare di pubblicarli).

Dunque, riepilogo la condizione reale:

La cartella x:\schede prezzo si trova su un server x:\

Al suo interno sono contenute esattamente 89 cartelle il cui nome corrisponde al nome del cliente (preferirei evitare di pubblicarlo).

All'interno di ogni cartella col nome del cliente sono contenuti i file (relativi a quel cliente) da cui voglio estrarre i dati.

Facendo girare la seguente macro:

'=========>>

 Option Explicit

 '--------->>

 Public Sub Tester()

     Dim FSO As Object

     Dim oFile As Object

     Dim oFiles As Object

     Dim oFolder As Object

     Dim oSubFolder As Object

     Dim WB As Workbook

     Dim SH As Worksheet, destSH As Worksheet

     Dim Rng As Range, rCell As Range

     Dim arrExclude As Variant, arrHeaders As Variant

     Dim iRow As Long

     Dim j As Long, k As Long

     Dim myFile As String, myFolder As String

     Dim Res As Variant

     Const sAddress = "F2,K2,C4,H4,C6,H6,E8,I7,I8,J8,L8,E9,I9,E10,E11,E12,E13,I14,J15,E16,J17,J18"                                                               '<<==== Modifica

     Const sFolder As String = "X:\SCHEDE PREZZO"                                               '<<==== Modifica

     Const sHeaders As String = "FILE ORIGINE,FOGLIO DI ORIGINE,CLIENTE,DATA,DESCRIZIONE,CODICE,DIMENSIONE,REVISIONE DISEGNO,PESO BARRA,BARRA EXT,MISURA EXT,BARRA INT,MISURA INT,LUNGH SPEZZ,MATERIALE,BASE METALLO,EXTRA MISURA,TOTALE METALLO,VALORE SFRIDO,PESO OCCORRENTE,COSTO MATERIALE,PESO FINITO,RECUPERO SFRIDO,COSTO MATERIA PRIMA"

     Set WB = ThisWorkbook

     Set destSH = WB.Sheets(1)

     iRow = 1

     arrExclude = VBA.Array("Calcolo peso", "Forme", "Calcolo peso ")

     arrHeaders = Split(sHeaders, ",")

     destSH.Range("A1:X1").Value = arrHeaders

     On Error GoTo XIT

     Application.ScreenUpdating = False

     Set FSO = CreateObject("Scripting.FileSystemObject")

     Set oFolder = FSO.GetFolder(sFolder)

     For Each oSubFolder In oFolder.SubFolders

         Set oFiles = oSubFolder.Files

         For Each oFile In oFiles

         Application.StatusBar = "Processing il file " & oFile.Path

             Set WB = Workbooks.Open(oFile)

             With WB

                 For Each SH In WB.Worksheets

                     With SH

                         j = 1

                         Res = Application.Match(.Name, arrExclude, 0)

                         If IsError(Res) Then

                             iRow = iRow + 1

                             With destSH

                                 .Cells(iRow, "A").Value = WB.FullName

                                 .Cells(iRow, "B").Value = SH.Name

                                 Set Rng = SH.Range(sAddress)

                                 For Each rCell In Rng.Cells

                                     j = j + 1

                                     .Cells(iRow, j + 1).Value = rCell.Value

                                 Next rCell

                             End With

                         End If

                     End With

                 Next SH

                 .Close savechanges:=False

             End With

         Next oFile

     Next oSubFolder

     destSH.UsedRange.EntireColumn.AutoFit

XIT:

     With Application

         .ScreenUpdating = True

         .StatusBar = False

     End With

 End Sub

 '<<=========

Parte l'estrazione, estrae TUTTI i dati nei file contenuti nella prima cartella, mi mostra l'avanzamento, ma NON PASSA ALLA SECONDA CARTELLA e alle successive.

Chiedo ancora scusa per l'esempio che ti ho postato ieri, la mia intenzione di non pubblicare i nomi dei clienti ha creato solo casino.

Qualora volessi darmi il tuo indirizzo email posso inviarti il file.

Grazie.

Ciao Red Mud.

Sono perplesso! Tu avevi detto

Mi risulta un po' laborioso inserire i path di ogni cartella contenente il mie file originali (più di 100 cartelle).

Non esiste un metodo più rapido considerando che sono tutte contenute a loro volta nella cartella "prezzi"? (sono tutte sottocartelle della cartella prezzi).

Di conseguenza, ho postato una versione rivista del mio codice che gestisce i file in tutte le sottodirectory della directory C: \ Prezzi.

Tuttavia, nella ultima risposta tu mostri  il percorso di un singolo file:

     Const sFolder As String = "C:\PROVE\SCHEDA ARTICOLO1.xslx"      

Per utilizzare la versione corrente del mio codice la costante sFolder dovrebbe indicare il percorso della directory che contiene le 100 sottodirectory. 

===

Regards

Norman

nome file:                            Scheda articolo1

percorso:                              C:\PROVE

Contenuto cella F2             Prova

Macro:

'=========>>

 Option Explicit

 '--------->>

 Public Sub Tester()

     Dim FSO As Object

     Dim oFile As Object

     Dim oFiles As Object

     Dim oFolder As Object

     Dim oSubFolder As Object

     Dim WB As Workbook

     Dim SH As Worksheet, destSH As Worksheet

     Dim Rng As Range, rCell As Range

     Dim arrExclude As Variant, arrHeaders As Variant

     Dim iRow As Long

     Dim j As Long, k As Long

     Dim myFile As String, myFolder As String

     Dim Res As Variant

     Const sAddress = "F2,K2,C4"                                                               '<<==== Modifica

     Const sFolder As String = "C:\PROVE\SCHEDA ARTICOLO1.xslx"                                               '<<==== Modifica

     Const sHeaders As String = "File di Origine,Foglio di Origine,Cliente,Data,Descrizione"

     Set WB = ThisWorkbook

     Set destSH = WB.Sheets(1)

     iRow = 1

     arrExclude = VBA.Array("Calcolo peso", "Forme")

     arrHeaders = Split(sHeaders, ",")

     destSH.Range("A1:E1").Value = arrHeaders

     On Error GoTo XIT

     Application.ScreenUpdating = False

     Set FSO = CreateObject("Scripting.FileSystemObject")

     Set oFolder = FSO.GetFolder(sFolder)

     For Each oSubFolder In oFolder.SubFolders

         Set oFiles = oSubFolder.Files

         For Each oFile In oFiles

         Application.StatusBar = "Processing il file " & oFile.Path

             Set WB = Workbooks.Open(oFile)

             With WB

                 For Each SH In WB.Worksheets

                     With SH

                         j = 1

                         Res = Application.Match(.Name, arrExclude, 0)

                         If IsError(Res) Then

                             iRow = iRow + 1

                             With destSH

                                 .Cells(iRow, "A").Value = WB.FullName

                                 .Cells(iRow, "B").Value = SH.Name

                                 Set Rng = SH.Range(sAddress)

                                 For Each rCell In Rng.Cells

                                     j = j + 1

                                     .Cells(iRow, j + 1).Value = rCell.Value

                                 Next rCell

                             End With

                         End If

                     End With

                 Next SH

                 .Close savechanges:=False

             End With

         Next oFile

     Next oSubFolder

     destSH.UsedRange.EntireColumn.AutoFit

XIT:

     With Application

         .ScreenUpdating = True

         .StatusBar = False

     End With

 End Sub

 '<<=========

Cattura schermo file da cui importare