Creare nuovo file excel estraendo i dati da altri file excel

Ciao Norman,

grazie.

ma:

Se lancio la macro "diagnostica" la esegue correttamente e non dà errore.

Se lancio la macro "tester" (tua ultima versione) dopo aver estratto correttamente dalla prima cartella, dà errore come file allegato.

Dove sbaglio?

Ti ho inviato file in pvt.

Ciao.

Ciao Red Mud,

ORA FUNZIONA! Importa tutti i 1480 file elencando percorso e nome file nel nuovo file.

Bene!

Ora devo ricostruire la parte che importa i valori delle celle che ho bisogno di importare vero?

Potresti riepilogarmi al completo la macro?

Certo, vedi di sotto.

Ps.

Mi sono accorto che avrei bisogno di importare anche la data dell'ultima modifica del file di origine. Hai suggerimenti?

Il nuovo codice inserisce la data dell'ultima modifica di ogni file nella colonna C.

Sostituisci il codice precedente con la seguente versione:

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

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 srcSH 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 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**"                                           '<<==== Modifica

    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 WB = ThisWorkbook

    Set destSH = WB.Sheets(1)

    iRow = 1

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

    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

            dDate = oFile.DateLastModified

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

            Set WB = Workbooks.Open(oFile)

            With WB

                For Each srcSH In WB.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

        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

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

===

Regards,

Norman

Ciao Norman.

Chiedo scusa, mio errore di distrazione!

Dopo che mi hai evidenziato il probabile eventuale errore ho corretto la macro con:

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

anziché:

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

(la mia cartella si trova sul server X: e non avevo aggiornato il tuo codice nella prima prova)

ORA FUNZIONA! Importa tutti i 1480 file elencando percorso e nome file nel nuovo file.

Grazie!

Ora devo ricostruire la parte che importa i valori delle celle che ho bisogno di importare vero?

Potresti riepilogarmi al completo la macro?

Ps.

Mi sono accorto che avrei bisogno di importare anche la data dell'ultima modifica del file di origine. Hai suggerimenti?

Ti sono estremamente riconoscente per la pazienza che stai dimostrando nell'interagire con un profano come me.

Ciao Red Mud,

errore di run-time 71 e che la riga

Avrebbe dovuto essere:

errore di run-time **76 (percorso non trovato)**e che la riga

===

Regards,

Norman