Creare nuovo file excel estraendo i dati da altri file excel

Ciao Red Mud,

Grazie!

Come supponevi tu, modificando la lunghezza della stringa sAddress il problema si è risolto.

Ho dovuto solo ricreare la sequenza delle intestazioni delle colonne del file destinazione.

Penso che siamo giunti al termine di questa laboriosa procedura.

Ti ringrazio calorosamente.

Saluti

Mi fa piacere che tu hai risolto il problema e ti ringrazio del gentle riscontro.

===

Regards,

Norman

Ciao Norman,

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 As String = "F2,K2,C4,H4,C6,H6,J8,L8,I7:I9," _

          & "E8:E13,I14,J15,E16,J17:J18,B21:B26,E21:E26," _

          & "H21:H26,J21:J26,O21:O26,B28,J28,I30,L30,L32," _

          & "D36:D38,F36:F38,I36:I38,P15: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," _

          & "FORMA BARRA INT,MISURA BARRA INT,MISURA EXT,MISURA BARRA EXT,MATERIALE," _

          & "PESO BARRA,LUNGH SPEZZONE,BASE METALLO,EXTRA MISURA," _

          & "TOTALE METALLO,VALORE SFRIDO,PESO OCCORRENTE," _

          & "COSTO MATERIALE,PESO FINITO,RECUPERO SFRIDO," _

          & "COSTO MATERIA PRIMA,LAV1,LAV2,LAV3,LAV4,LAV5," _

          & "LAV6,T_LAV1,T_LAV2,T_LAV3,T_LAV4," _

          & "T_LAV5,T_LAV6,COSTOH_LAV1,COSTOH_LAV2,COSTOH_LAV3," _

          & "COSTOH_LAV4,COSTOH_LAV5,COSTOH_LAV6,COSTO_LAV1,COSTO_LAV2," _

          & "COSTO_LAV3,COSTO_LAV4,COSTO_LAV5,COSTO_LAV6,MACCH_LAV1," _

          & "MACCH_LAV2,MACCH_LAV3,MACCH_LAV4,MACCH_LAV5,MACCH_LAV6," _

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

          & "NOTE_PR1,NOTE_PR2,NOTE_PR3," _

          & "PERIODO_PR1,PERIODO_PR2," _

          & "PERIODO_PR3,PREZZO_PR1,PREZZO_PR2,PERIODO_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

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

Ciao Norman.

Grazie!

Come supponevi tu, modificando la lunghezza della stringa sAddress il problema si è risolto.

Ho dovuto solo ricreare la sequenza delle intestazioni delle colonne del file destinazione.

Penso che siamo giunti al termine di questa laboriosa procedura.

Ti ringrazio calorosamente.

Saluti

Red Mud

Ciao Red Mud,

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.

Bene!!

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:

[CUT]

                 

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?

Prima di controllare le modifiche che hai fatto al mio codice, quando riscontri l'errore, quale riga del codice viene evidenziata?

===

Regards,

Norman