Creare nuovo file excel estraendo i dati da altri file excel

Ciao Red Mud,

In pratica parte la macro....compila le intestazioni di campo....ma non riempie i campi con i relativi dati.

Non dà nessun errore.

Il codice funzione per me senza alcun problema

Potresti indicare il nome, il percorso completo di uno dei file; potresti anche indicare il nome di un foglio di interesse e il contenuto della cella F2 di quel file?

===

Regards,

Norman

Non riesco ad ottenere il risultato con l'ultima versione che hai postato.

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

 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"

     Const sFolder As String = "C:\Users\ANDREA\Documents\Ombg"

     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

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

In pratica parte la macro....compila le intestazioni di campo....ma non riempie i campi con i relativi dati.

Non dà nessun errore.

Poco male comunque. Ho aggiornato la precedente versione che avevi suggerito modificando la riga del percorso come hai suggerito nell'ultima versione e quella funziona.

Grazie ancora.

Ciao Red Mud

Grazie. Eccezionale!

Funziona.

Non mi resta che implementare campi e celle da importare e completare il mio nuovo file.

Bene!

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).

La necessità di elencare i vari percorsi era dovuta unicamente al fatto che non avevi rivelato il fatto che ci fosse una directory base! Essendo consapevole di questa directory, prova la seguente versione che dovrebbe ovviare a questo problema:

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

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:\Prezzi**"                                               '<<==== 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

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

Nota che con questa versione aggiornata, è anche possibile seguire lo stato di avanzamento di ogni file sulla barra di stato nella parte inferiore dello schermo

===

Regards,

Norman

Grazie. Eccezionale!

Funziona.

Non mi resta che implementare campi e celle da importare e completare il mio nuovo file.

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).

Grazie ancora.