Creare nuovo file excel estraendo i dati da altri file excel

Ciao Norman,

premetto che l'ultima versione che mi ha mandato estrae correttamente i valori dalle celle del foglio origine. Esegue tutta le procedura in modo corretto.

Ho però inserito alcune celle da estrarre che non avevo aggiunto in precedenza (sAddress).

Ho anche aggiunto le intestazioni (sHeaders).

il codice definitivo è il seguente:

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

 Public Sub Tester()

     Dim FSO As Object

     Dim oFile As Object

     Dim oFiles As Object

     Dim oFolder As Object

     Dim oSubFolder As Object

     Dim srcWB As Workbook, destWB As Workbook

     Dim srcSH As Worksheet, destSH As Worksheet, aSH As Worksheet

     Dim Rng As Range, rCell As Range

     Dim arrExclude As Variant, arrHeaders As Variant

     Dim arrAltriFile() As Variant

     Dim iRow As Long

     Dim i As Long, j As Long, k As Long

     Dim myFile As String, myFolder As String

     Dim Res As Variant

     Dim dDate As Date

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

     Const sAddress = "F2,K2,C4,H4,C6,H6,E8,I7,I8,J8,L8," _

          & "E9,I9,E10,E11,E12,E13,I14,J15,E16,J17,J18," _

    & "B21,E21,H21,J21,O21,B22,E22,H22,J22,O22," _

& "B23,E23,H23,J23,O23,B24,E24,H24,J24,O24," _

& "B25,E25,H25,J25,O25,B26,E26,H26,J26,O26,B28,J28,I30," _

& "L30,L32,D36,F36,I36,D37,F37,I37,D38,F38,I38," _

& "P15,P16,P17,P18"                     '<<==== Modifica

     Const sFolder As String = "X:\SCHEDE PREZZO"

     Const sHeaders As String = "CARTELLA ORIGINE,FILE ORIGINE," _

          & "ULTIMA MODIFICA,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**,LAV1,T_LAV1,COSTOH_LAV1,COSTO_LAV1,MACCH_LAV1," _**

& "LAV2,T_LAV2,COSTOH_LAV2,COSTO_LAV2,MACCH_LAV2," _

& "LAV3,T_LAV3,COSTOH_LAV3,COSTO_LAV3,MACCH_LAV3," _

& "LAV4,T_LAV4,COSTOH_LAV4,COSTO_LAV4,MACCH_LAV4," _

& "LAV5,T_LAV5,COSTOH_LAV5,COSTO_LAV5,MACCH_LAV5," _

& "LAV6,T_LAV6,COSTOH_LAV6,COSTO_LAV6,MACCH_LAV6," _

& "COMMENTI1,TOT_NETTO,MAGG,TOT_MAGG,TOTALE," _

& "NOTE_PR1,PERIODO_PR1,PREZZO_PR1," _

& "NOTE_PR2,PERIODO_PR2,PREZZO_PR2," _

& "NOTE_PR3,PERIODO_PR3,PREZZO_PR3," _

& "LOTTO_MIN,DATA_CONS,IMBALLAGGIO,SPEDIZIONE"     '<<==== Modifica"

     Set destWB = ThisWorkbook

     Set destSH = destWB.Sheets(1)

     iRow = 1

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

     arrHeaders = Split(sHeaders, ",")

     With destSH.Range("A1").Resize(1, UBound(arrHeaders) + 1)

         .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

             If oFile.Name Like "*.xls*" Then

                 dDate = oFile.DateLastModified

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

                 Set srcWB = Workbooks.Open(oFile)

                 With srcWB

                     For Each srcSH In .Worksheets

                         With srcSH

                             j = 1

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

                             If IsError(Res) Then

                                 iRow = iRow + 1

                                 With destSH

                                     .Cells(iRow, "A").Value = oSubFolder.Path

                                     .Cells(iRow, "B").Value = oFile.Path

                                     .Cells(iRow, "C").Value = dDate

                                     .Cells(iRow, "D").Value = srcSH.Name

                                     Set Rng = srcSH.Range(sAddress)

                                     For Each rCell In Rng.Cells

                                         j = j + 1

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

                                     Next rCell

                                 End With

                             End If

                         End With

                     Next srcSH

                     .Close savechanges:=False

                 End With

             Else

                     i = i + 1

                     ReDim Preserve arrAltriFile(1 To i)

                     arrAltriFile(i) = oFile.Path

             End If

         Next oFile

     Next oSubFolder

     destSH.UsedRange.EntireColumn.AutoFit

     If CBool(i) Then

         With destWB

            On Error Resume Next

             Set aSH = .Sheets("AltriFile")

             On Error GoTo XIT

             If Not aSH Is Nothing Then

                 aSH.Cells.ClearContents

             Else

                 Set aSH = .Sheets.Add(after:=.Sheets(1))

             End If

         End With

         With aSH

             .Name = "AltriFile"

             .Range("A2").Resize(i).Value = arrAltriFile

         End With

     End If

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

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

Alla estrazione del primo file mi presenta il seguente errore:

ERRORE 1004 (Metodo 'Range' dell'oggetto '_Worksheet' non riuscito) nella routine: Tester

e interrompe l'estrazione.

Cosa ho omesso di aggiornare?

Grazie,

Red Mud

Ciao Red Mud,

Per ragioni di completezza, se i file thumb.db non devono essere cancellati, il codice finale diventerebbe:

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

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 srcWB As Workbook, destWB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet, aSH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim arrExclude As Variant, arrHeaders As Variant

    Dim arrAltriFile() As Variant

    Dim iRow As Long

    Dim i As Long, j As Long, k As Long

    Dim myFile As String, myFolder As String

    Dim Res As Variant

    Dim dDate As Date

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

    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**"

    Const sHeaders As String = "CARTELLA ORIGINE,FILE ORIGINE," _

& "ULTIMA MODIFICA,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"                                                                           '<<==== Modifica

    Set destWB = ThisWorkbook

    Set destSH = destWB.Sheets(1)

    iRow = 1

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

    arrHeaders = Split(sHeaders, ",")

    With destSH.Range("A1").Resize(1, UBound(arrHeaders) + 1)

        .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

            If oFile.Name Like "*.xls*" Then

                dDate = oFile.DateLastModified

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

                Set srcWB = Workbooks.Open(oFile)

                With srcWB

                    For Each srcSH In .Worksheets

                        With srcSH

                            j = 1

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

                            If IsError(Res) Then

                                iRow = iRow + 1

                                With destSH

                                    .Cells(iRow, "A").Value = oSubFolder.Path

                                    .Cells(iRow, "B").Value = oFile.Path

                                    .Cells(iRow, "C").Value = dDate

                                    .Cells(iRow, "D").Value = srcSH.Name

                                    Set Rng = srcSH.Range(sAddress)

                                    For Each rCell In Rng.Cells

                                        j = j + 1

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

                                    Next rCell

                                End With

                            End If

                        End With

                    Next srcSH

                    .Close savechanges:=False

                End With

            Else

                    i = i + 1

                    ReDim Preserve arrAltriFile(1 To i)

                    arrAltriFile(i) = oFile.Path

            End If

        Next oFile

    Next oSubFolder

    destSH.UsedRange.EntireColumn.AutoFit

    If CBool(i) Then

        With destWB

            On Error Resume Next

            Set aSH = .Sheets("AltriFile")

            On Error GoTo XIT

            If Not aSH Is Nothing Then

                aSH.Cells.ClearContents

            Else

                Set aSH = .Sheets.Add(after:=.Sheets(1))

            End If

        End With

        With aSH

            .Name = "AltriFile"

            .Range("A2").Resize(i).Value = arrAltriFile

        End With

    End If

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

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

===

Regards,

Norman

Ciao Red Mud,

Mi sono espresso male: Il file thumbs.db è sempre e solo elencato nel foglio AltriFile.

In tal caso tutto va bene! L'unico scopo del foglio AltriFile è di informarti dei eventuali file di tipo non Excel.

Considerato che l'estrazione sembra efficace,  non penso sia necessario intervenire con l'eliminazione

dei vari file thumbs.db sparsi nelle cartelle.

Concordi?

Sì, certo!

Ora ti chiederei di segnare mio codice come Risposta per chiudere questo thread. 

===

Regards,

Norman

Ciao Norman.

Ha elencato 61 volte un file presente nelle stessa cartella (la prima dell'estrazione).

Il file è sempre il solito...elencato 61 volte....thumbs.db

Questo mi sorprende molto, in quanto l'istruzione

           If oFile.Name Like "*.xls*" Then

dovrebbe assicurarsi che solo i file con un'estensione che comprende .xls siano elaborati sul primo foglio riepilogativo. Sei sicuro che in realtà il file  thumbs.db non sia elencato sul secondo foglio ripielogativo AltriFile?

Mi sono espresso male: Il file thumbs.db è sempre e solo elencato nel foglio AltriFile.

Considerato che l'estrazione sembra efficace,  non penso sia necessario intervenire con l'eliminazione

dei vari file thumbs.db sparsi nelle cartelle.

Concordi?

Saluti,

Red mud.