unione file excel

Hai un problema con Excel?

Nuova discussione

unione file excel
di paolo (utente non iscritto) data: 12/03/2014 10:02:23
Buongiorno

lo so che sono ripetitivo ma non riesco a copiare il codice VBA ed ad adattarlo al mio problema;
Devo unire i 5 file excel ( Automatico; Archiviate; A;B;C)(i file sono contenuti tutti nella stessa cartella C:Users653661Desktop )dove i nomi dei file e le colonne sono fissi variano giornaliermente i numeri delle righe; io devo creare un unico file (Unione)ho visto dei codici per fare cose simili ma mi restituisce degli errori che non capisco potete aiutarmi

Private Sub Sfoglia_Files()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' ATTENZIONE RICHIEDE L'ATTIVAZIONE DELLA LIBRERIA MICROSOFT SCRIPTING RUNTIME '''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim strPath As String
   
    Dim objFSY As FileSystemObject
    Dim objFOL As Folder
    Dim objFIL As File
    
    Dim wbFrom As Workbook, wbTo As Workbook
    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim x As Long, i As Long
    Dim rngCopy As Range
    
    Set wbTo = ThisWorkbook
    Set wsTo = wbTo.Sheets(1)
     
    strPath = "C:ProveFiles" '''QUI IL PERCORSO
    
    Set objFSY = New FileSystemObject
    Set objFOL = objFSY.GetFolder(strPath)

    For Each objFIL In objFOL.Files
        x = wsTo.Range("B" & wsTo.Rows.Count).End(xlUp).Row + 1
        
        Set wbFrom = Application.Workbooks.Open(objFIL)
        Set wsFrom = wbFrom.Sheets(1)
            With wsFrom
                i = .Range("B" & .Rows.Count).End(xlUp).Row
                Set rngCopy = .Range("B3:Q" & i)
                rngCopy.Copy wsTo.Cells(x, 2)
                Set rngCopy = Nothing
            End With
        wbFrom.Close 0
        Set wbFrom = Nothing
        Set wsFrom = Nothing
    Next

    Set objFSY = Nothing
    Set objFOL = Nothing
    Set wbTo = ThisWorkbook
    Set wsTo = Nothing
End Sub

di Lucas87 data: 12/03/2014 10:10:17
Allega uno dei file.
Togli i dati sensibili e sostituiscili con valori a caso, interessa la struttura.
di Grograman (utente non iscritto) data: 12/03/2014 10:18:59
Bhè intanto hai riportato male il codice

Altrimenti poi la gente dice che posto codici non funzionanti :D
strPath = "C:ProveFiles" '''QUI IL PERCORSO è strPath = "C:ProveFiles" '''QUI IL PERCORSO
invio file
di paolo (utente non iscritto) data: 12/03/2014 10:29:58
ho allegato i file ne ho messo solo due se volete posto tutti

saluti

l'errore mi viene dato all'inizio

allego schermata di errore

di Grograman (utente non iscritto) data: 12/03/2014 10:35:00
Ma il codice lo leggete prima di provarlo?

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' ATTENZIONE RICHIEDE L'ATTIVAZIONE DELLA LIBRERIA MICROSOFT SCRIPTING RUNTIME '''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' Per l'attivazione andare su "Strumenti", "Riferimenti", cercare e spuntare il nome ''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' ATTENZIONE RICHIEDE L'ATTIVAZIONE DELLA LIBRERIA MICROSOFT SCRIPTING RUNTIME '''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' Per l'attivazione andare su "Strumenti", "Riferimenti", cercare e spuntare il nome ''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' ATTENZIONE RICHIEDE L'ATTIVAZIONE DELLA LIBRERIA MICROSOFT SCRIPTING RUNTIME '''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' Per l'attivazione andare su "Strumenti", "Riferimenti", cercare e spuntare il nome ''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' ATTENZIONE RICHIEDE L'ATTIVAZIONE DELLA LIBRERIA MICROSOFT SCRIPTING RUNTIME '''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' Per l'attivazione andare su "Strumenti", "Riferimenti", cercare e spuntare il nome ''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

di Lucas87 data: 12/03/2014 10:38:28
Il codice funziona.
O meglio va modificato.

Sostituisci

Set rngCopy = .Range("B3:Q" & i)
rngCopy.Copy wsTo.Cells(x, 2)

con

Set rngCopy = .Range("A3:CQ" & i)
rngCopy.Copy wsTo.Cells(x, 1)

paolo
di paolo (utente non iscritto) data: 12/03/2014 11:28:48
secondo me doppia qualcosa perchè restituisce 1512 righe a fronte di 759 allego tutti i file con la macro sperando in un ultimo aiuto

grazie
di Lucas87 data: 12/03/2014 11:39:36
Hai allegato un archivio vuoto...
di paolo (utente non iscritto) data: 12/03/2014 11:43:55
scusate riallego

di Lucas87 data: 12/03/2014 12:00:32
Ma porc.....
Il codice funziona.
Semplicemente apre TUTTI i file della cartella e copia i dati.
Vuol dire che apre A,B,C,Archiviate ,Automatico e scrive in tutto 760 righe
Poi apre anche unione manuale e aggiunge altre 759 righe
760+759=1519

sostituisci il codice con questo

Private Sub Sfoglia_Files()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' ATTENZIONE RICHIEDE L'ATTIVAZIONE DELLA LIBRERIA MICROSOFT SCRIPTING RUNTIME '''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim strPath As String
   
    Dim objFSY As FileSystemObject
    Dim objFOL As Folder
    Dim objFIL As File
    Dim wbFrom As Workbook, wbTo As Workbook
    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim x As Long, i As Long
    Dim rngCopy As Range
    Set wbTo = ThisWorkbook
    Set wsTo = wbTo.Sheets(1)
    strPath = "........................" '''QUI IL PERCORSO NON SERVE LA  FINALE
    Set objFSY = New FileSystemObject
    Set objFOL = objFSY.GetFolder(strPath)
    For Each objFIL In objFOL.Files
        x = wsTo.Range("B" & wsTo.Rows.Count).End(xlUp).Row + 1
        Set wbFrom = Application.Workbooks.Open(objFIL)
        Set wsFrom = wbFrom.Sheets(1)         'PUNTA SUL FOGLIO 1
            With wsFrom
                i = .Range("B" & .Rows.Count).End(xlUp).Row 'SULLA COLONNA B DEVONO SEMPRE ESSERCI VALORI
                Set rngCopy = .Range("a2:cQ" & i)       'COPIA I VALORI DA A2 A CQ+ULTIMA RIGA
                rngCopy.Copy wsTo.Cells(x, 1)   'SCRIVE DOPO L'ULTIMA RIGA
                Set rngCopy = Nothing
            End With
        wbFrom.Close 0
        Set wbFrom = Nothing
        Set wsFrom = Nothing
    Next
    Set objFSY = Nothing
    Set objFOL = Nothing
    Set wbTo = ThisWorkbook
    Set wsTo = Nothing
End Sub

di Lucas87 data: 12/03/2014 12:01:40
Il codice che usi ora salta una riga per ogni file
di paolo (utente non iscritto) data: 12/03/2014 12:29:26
Ciao e Grazie a tutti per me va già tutto bene cosi ma sarebbe perfetto se riusciste a risolvere anche questo piccolo problema allegato
di Lucas87 data: 12/03/2014 12:39:26
La macro cerca di aprire il file che stai usando (quello con il complessivo)
Soluzione 1:
Il file complessivo lo togli dalla cartella dove si trovano gli altri file.
Soluzione 2:
Lasci il file nella cartella e all'interno del ciclo for each....next
metti
If objFIL.Name <> wbTo.Name Then...end if
in modo che quando trova il file che stai usando lo salta.

La soluzione 2 è però rischiosa (detto da Grograman) perchè i file aperti generano dei file temporanei che la macro potrebbe cercare di aprire creando errori.
Come soluzione si potrebbe far controllare l'estensione del file

di Raffaele_53 (utente non iscritto) data: 12/03/2014 14:16:58
Una domanda
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' ATTENZIONE RICHIEDE L'ATTIVAZIONE DELLA LIBRERIA MICROSOFT SCRIPTING RUNTIME '''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Io non so se sul mio PC sia installata, però questo codice mi sembra a posto.
Naturalmente cambiare il percorso

Option Explicit
Sub copia()
    Dim WB As Workbook
    Dim Ws1 As Worksheet
    Dim Percorso As String, nomeFile As String, Uriga As Long, Ur As Long
    Percorso = "D:106mimmo 2" '<=== QUI DIGITA IL TUO PERCORSO con la  finale
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set Ws1 = ThisWorkbook.Worksheets("Foglio1")
    nomeFile = Dir(Percorso)
    Do While nomeFile <> ""
        If nomeFile <> ThisWorkbook.Name Then
            Workbooks.Open (Percorso & "" & nomeFile)
            Ur = Workbooks(nomeFile).Worksheets("Reportistica").Range("B" & Rows.Count).End(xlUp).Row
            Workbooks(nomeFile).Worksheets("Reportistica").Range("A2:CQ" & Ur).Copy
            Uriga = Ws1.Range("B" & Rows.Count).End(xlUp).Row + 1
            Ws1.Range("A" & Uriga).PasteSpecial
            Workbooks(nomeFile).Close False
        End If
        nomeFile = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Fatto"
    Set Ws1 = Nothing
End Sub

di Grograman (utente non iscritto) data: 12/03/2014 14:49:57
@ Raffaele: La libreria di cui parli va attivata a livello di progetto non di PC. Serve ad utilizzare alcuni oggetti dedicati all'ambiente "scrivania".
Dim objFSY As FileSystemObject
Dim objFOL As Folder
Dim objFIL As File

Ad esempio sono oggetti che potresti utilizzare normalmente, ma con la libreria attivata ti vengono proposte le proprietà dei relativi oggetti così come quando digiti "application." ti propone proprietà/metodi dell'oggetto Application.

Utilizzando questa libreria ho scoperto un sacco di metodi applicabili o proprietà utili che non avrei saputo usare se non me le avesse proposte la libreria stessa
grazie
di paolo (utente non iscritto) data: 12/03/2014 15:14:24
grazie a tutti

Vuoi Approfondire?