UNIRE PIU FOGLI excel IN UNO UNICO

[Blu_ice]

Ciao

Ho cercato varie macro in rete senza venirne a capo, vorrei unire in un solo foglio tutte le cartelle di excel, ES pippo1, pippo2, pippo3 in un foglio Globale, dove nel foglio uno della cartella globale accodasse tutto sullo stesso foglio

ES:
Pippo1.xls
foglio1
sheet2
Pippo2.xls
foglio1
Pippo3.xls
foglio1

risultato
Globale.xls
Foglio1( tutte le informazioni qua dentro)

un esempio ma non funzionava
viewtopic.php?t=109345

Ho visto che con le Query sembrebbe funzionare, ma non va su tutte le versioni di excel o su pc lenti ha problemi

[Blu_ice]

questo è un fax simile di merge, ma non li inserisce tutte in un unica foglio accodandoli

Codice: Seleziona tutto

Sub Merge()
Path = "C:\Users\test\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub


[alfrimpa]

Blu Ice allega dei file di esempio con dati non sensibili e mostra sul file Globale come deve essere riportato il risultato.

[Blu_ice]

dovrei crealo l'esempio.... si tratta di concatenare in uno unico Foglio tutto il contenuto di tutti i fogli presenti nelle cartelle di exel, della cartella e possono essere 50/60 cartelle ed ogni foglio ha lunghezze diverse....massimo arrivo a 3000/4000 righe unendo tutti i fogli

ogni cartella è composta da 2-5 fogli

Codice: Seleziona tutto


Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
Sheets(J).Activate ' make the sheet active
Range("A1").Select
Selection.CurrentRegion.Select ' select all cells in this sheets
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub


Cosa conisgiliate per convertire i pdf in excel, perche i dati sorgenti sono salvati su tabelle pdf

[klingklang]

Ciao, puoi provare questo mio tool, fammi sapere

[Anthony47]

Nel caso che i risultati tramite il tool suggerito e sviluppato da kingklang non fossero idonei...

In quest'altra discussione veniva presentata la Sub RIEP, poi evoluta in Sub RIEP2: viewtopic.php?f=26&t=106455

L'obiettivo era creare un unico "riepilogo" leggendo il "primo foglio" di una serie di file Excel memorizzati tutti in una unica directory.
Poiche' la tua esigenza e' di riepilogare "tutti i fogli di tutti i file" dobbiamo fare una piccola modifica in modo da ciclare attraverso tutti i fogli dei file man mano che vengono esaminati.

Il codice finale dovrebbe essere

Codice: Seleziona tutto

Sub RIEP3()
Dim myDir As String, myCFile As String, myLast As Long
Dim newWB As Workbook, myUsed As Long
'
'Crea il Riepilogo su Foglio1 di un NUOVO WORKBOOK
'
myDir = "D:\PROVA\"                 '<<< La dir dei file da consolidare (con \ finale)
'
Application.EnableEvents = False
Debug.Print vbCrLf & vbCrLf & ">>>>>>>>>> "    'Per prova
Set newWB = Workbooks.Add           'rea un nuovo Workbook
myCFile = Dir(myDir & "*.xls*")
Do
    If myCFile = "" Then Exit Do
    'On Error Resume Next
    myLast = getLast
    Debug.Print myLast, myCFile                     ' per prova
    newWB.Sheets(1).Cells(myLast + 1, 1) = ">>>> " & myCFile: myLast = myLast + 1    '??? Log WorkbookName
    Workbooks.Open (myDir & myCFile)
    For I = 1 To Sheets.Count
        Sheets(I).Select
        If Sheets(I).Type = xlWorksheet Then
            myUsed = getLast
            If myUsed > 0 Then       
                    newWB.Sheets(1).Cells(myLast + 1, 1) = "##### " & ActiveSheet.Name: myLast = myLast + 1    '??? Log WorksheetName
                    ActiveSheet.Range("A1:AZ" & myUsed).Copy newWB.Sheets(1).Cells(myLast + 1, 1)
                    myLast = myLast + myUsed
            End If                       
        End If
    Next I
    ActiveWorkbook.Close False
myCFile = Dir
Loop
Application.EnableEvents = True
MsgBox ("Riepilogo completato su nuovo File...")
End Sub


Function getLast() As Long
Dim LastR As Long
On Error Resume Next
LastR = Cells.Find(What:="*", After:=[A1], _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious).Row
On Error GoTo 0
getLast = LastR
End Function

Va messo tutto in un Modulo standard del vba di un file di servizio (anche Personal.xlsm); la riga marcata <<< va personalizzata come da commento.
Poi all'occorrenza va lanciata la Sub RIEP3
La macro creera' UN NUOVO FILE, e al suo interno incollera' il contenuto di tutti i fogli di tutti i file trovati nella directory dichiarata.
La copia e' limitata alle prime 50 colonne dei fogli; se pensi che sia un problema si puo' gestire meglio la larghezza di copia.

Vengono inseriti nel foglio di riepilogo, in colonna A, il nome del file preceduto da >>>> e il nome dei singoli fogli preceduti da <<<<. Se questa pretazione non e' gradita allora vanno rimosse in toto le due linee marcate ??? Log WorkbookName /Log WorksheetName

Fai sapere...