CREARE UNICO FILE EXCEL

[nicola_na78]

Ciao a tutti, ancora una volta avrei bisogno del vostro preziosissimo aiuto.

in una cartella "documenti" ci sono dei file excel dove ognuno di questi nel "foglio1" contengono delle informazioni.
Queste informazioni partendo dal primo file fino all'ultimo le dovrei copiare in un nuovo file che chiamerò "file-report" dove questo conterra' nel foglio1 il primo file, nel foglio2 il secondo file e così fino all'ultimo presente nella cartella documenti.

Vi ringrazio anticipatamente

Buona giornata
win7
office2007

[Anthony47]

Volendo ricliclare pezzi di codice gia' pubblicato sono partito dalla Function MonoDirXlsm descritta qui: viewtopic.php?f=26&t=109690#p643619
Questa ci dara' l'elenco dei file presenti nella directory che vuoi "riepilogare"

Il resto della macro e' prelevato da discussioni aperte dall'utente TAV:
viewtopic.php?f=26&t=109769&p=644159#p644072
viewtopic.php?f=26&t=109690#p643619

(creare in un unico Foglio un riepilogo da tanti file)
con l'unica variante che invece di accodare su uno stesso foglio si importano nel file tanti fogli quanti sono i file.

Il codice complessivo:

Codice: Seleziona tutto

Sub RiepNNa()
Dim FArr() As String, StrDir As String, Filtr As String
Dim NumF As Long, skF As String, fCnt As Long
Dim tdWb As String, mioFile As String
'
ReDim FArr(1 To 1)
Filtr = "*.xls"                        '<<< Il "filtro"  (ok cosi' per file Excel)
StrDir = "C:\IlPercorso                '<<< Il Percorso dei files
'
NumF = MonoDirXlsm(StrDir, Filtr, FArr)
Application.EnableEvents = False
For I = 1 To NumF
neF:
    On Error GoTo gErr
    mioFile = FArr(I)
    If mioFile <> "" And mioFile <> ThisWorkbook.FullName Then
        Workbooks.Open mioFile, 0
        On Error GoTo 0
        tdWb = ActiveWorkbook.Name
        Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        On Error Resume Next
        ActiveSheet.Name = tdWb
        On Error GoTo 0
        fCnt = fCnt + 1
        Workbooks(tdWb).Close False
    End If
Next I
GoTo Complet
gErr:
    skF = skF & mioFile & vbCrLf
    Resume neF
Complet:
Application.EnableEvents = True
mymess = "Completato: " & vbCrLf & "File Processati: " & fCnt
If Len(skF) > 3 Then mymess = mymess & vbCrLf & "Non processati i files:" & _
  vbCrLf & skF
MsgBox (mymess)
End Sub


Function MonoDirXlsm(ByVal ccDir As String, myFilt As String, ByRef cStore As Variant) As Long
Dim myInd, myF As String
'
If Right(ccDir, 1) <> Application.PathSeparator Then ccDir = ccDir & Application.PathSeparator
myF = Dir(ccDir & myFilt)
Do While myF <> ""
Debug.Print myF
    myInd = UBound(cStore)
    ReDim Preserve cStore(1 To myInd + 1)
    cStore(myInd) = ccDir & myF
    DoEvents
    myF = Dir
Loop
MonoDirXlsm = UBound(cStore) - 1
End Function


Il codice va messo in un modulo standard del vba; le istruzioni marcate <<< vanno personalizzate come da commenti
Poi all'occorrenza va eseguita la Sub RiepNNa.
I singoli file presenti nella directory dichiarata verranno aperti in sequenza e il primo foglio sara' copiato nel file che contiene la macro; se possibile, ai fogli verra' assegnato il nome del file che li conteneva.
A conclusione, un messaggio informera' di quanti file sono stati processati e quali eventualmente non e' stato possibile aprire.

Fai sapere...

keyw:
crea unico riepilogo da tanti file copia fogli in file di riepilogo
make summary from many files copy sheet sheets worksheet to summary file workbook

[nicola_na78]

Ciao Anthony47,
grazie mille!!!! provo e ti faccio sapere