Copia dati da più files di fogli diversi

[apocrimata75]

Ciao ragazzi, vorrei chiedere ai più esperti un aiuto, se possibile.

Sto usando questa macro (del forum in un vecchio post) per copiare i dati contenuti in più sheets nell'unico denominato "riepilogo" di un unico file.

Codice: Seleziona tutto

Sub Consolida()
Dim myArea As Range, I As Long, LastR As Long, NextR As Long, CopyCol As String
'
CopyCol = "b:h"         '<<Le colonne da copiare, a partire da b
'
Range(CopyCol).Resize(1).Select

For I = 1 To Worksheets.Count
    If UCase(Left(Sheets(I).Name, 4)) <> "RIEP" Then
        Sheets(I).Select
        LastR = FindLast(ActiveSheet, CopyCol)
        Set myArea = Application.Intersect(Range(CopyCol), Range("2:" & LastR))
        NextR = FindLast(Sheets("Riepilogo"), CopyCol) + 1
        myArea.Copy Destination:=Sheets("Riepilogo").Cells(NextR, "A")
    End If
Next I
Range(CopyCol).Resize(1).Copy Destination:=Sheets("Riepilogo").Range("a1")
Sheets("Riepilogo").Select
Range("A16").Select
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
End Sub

Function FindLast(ByRef mySh As Worksheet, ByVal myCols As String) As Long
Dim Last
With mySh.Range(myCols)
  Set Last = .Find(What:="*", After:=.Cells(1, 1), SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlFormulas)
End With
If Last Is Nothing Then FindLast = 1 Else FindLast = Last.Row
End Function


Ora necessiterei di alcune implementazioni (quello che facevo con un file, ottenerlo da più files):

Data la cartella "IF"
contenente un numero variabile di files in excel "A" "B" "C" ecc. (con all'interno più sheets) e quello "rapporti_00" che contiene il foglio "riepilogo"

vorrei copiare i dati di ogni file sull'unico sheet "riepilogo" del file "rapporti_00".

Spero di aver spiegato il tutto e vi ringrazio in anticipo per l'aiuto.

[Anthony47]

Quindi vorresti aprire ogni file contenuto nella posizione Drive:\Path\Subpath\IF, selezionare ogni foglio del file ed esportare il contenuto di ogni foglio come fa ora la Sub Consolida?

Ciao

[apocrimata75]

Si, ma capisco che è molto difficile. Per ora, continuando a smanettare ho impostato una macro che:
1 crea il foglio "riepilogo"
2 copia i dati da ogni sheet (dopo opportune modifiche)
3 copia quanto sopra nell'unico foglio "riepilogo"
4 elimina le righe vuote

Non ho risolto quanto cercavo, ma per ora non riesco a fare di meglio

Codice: Seleziona tutto

Sub Consolida()
Call riepinew
Call fogli

Dim myArea As Range, I As Long, LastR As Long, NextR As Long, CopyCol As String
'
CopyCol = "a:l"         '<<Le colonne da copiare, a partire da b
'
Range(CopyCol).Resize(1).Select

For I = 1 To Worksheets.Count
    If UCase(Left(Sheets(I).Name, 4)) <> "RIEP" Then
        Sheets(I).Select
        LastR = FindLast(ActiveSheet, CopyCol)
        Set myArea = Application.Intersect(Range(CopyCol), Range("2:" & LastR))
        NextR = FindLast(Sheets("Riepilogo"), CopyCol) + 1
        myArea.Copy Destination:=Sheets("Riepilogo").Cells(NextR, "A")
    End If
Next I
Range(CopyCol).Resize(1).Copy Destination:=Sheets("Riepilogo").Range("a1")
Sheets("Riepilogo").Select
Call mEliminaRigheVuote

End Sub

Function FindLast(ByRef mySh As Worksheet, ByVal myCols As String) As Long
Dim Last
With mySh.Range(myCols)
  Set Last = .Find(What:="*", After:=.Cells(1, 1), SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlFormulas)
End With
If Last Is Nothing Then FindLast = 1 Else FindLast = Last.Row
End Function
Sub fogli()
For F = 1 To Worksheets.Count
If Sheets(F).Name <> "Richiesta" And Sheets(F).Name <> "Dati Anagrafici" And Sheets(F).Name <> "riepilogo" Then    '<<<<< qui elenca dolo i fogli che NON vuoi siano processati
Sheets(F).Select
    Range("A2").Select
    Selection.EntireColumn.Insert
    Selection.EntireColumn.Insert
    Range("A7").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[3]="""","""",R3C3)"
    Range("B7").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[2]="""","""",R3C5)"
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[1]="""","""",R3C6)"
    Range("C3").Select
    ActiveCell.FormulaR1C1 = "='Dati Anagrafici'!R[1]C"
   
    Range("a7:c7").Select
    Selection.AutoFill Destination:=Range("a7:c315"), Type:=xlFillDefault
    Range("a7:c315").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("F26").Select
End If  '<<<< aggiungere qui
Next F '<<<< aggiungere qui
End Sub
Public Sub mEliminaRigheVuote()

Sheets("Riepilogo").Select
On Error GoTo RigaErrore

    Dim lngNumeroRiga As Long
    Dim lngLong As Long
   
    With ActiveSheet
   
        lngNumeroRiga = .Range("A65536").End(xlUp).Row
       
            For lngLong = lngNumeroRiga To 1 Step -1
                If .Cells(lngLong, 1).Value = "" Then
                    .Rows(lngLong).Delete Shift:=xlUp
                End If
            Next lngLong
           
        .Cells(1, 1).Select
           
    End With
   
    Exit Sub

RigaErrore:

    MsgBox Err.Number & vbCrLf & Err.Description
End Sub
Sub riepinew()
'
' Macro1 Macro
'

'
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Foglio1").Select
    Sheets("Foglio1").Name = "riepilogo"
End Sub