query per importare celle da più file excel uguali contenuti in sottocartelle diverse

Question

Buongiorno a tutti,

avrei la necessità di riepilogare una serie di dati contenuti in file excel formattati tutti uguali.

questi file excel non sono nominati tutti uguali e sono contenuti in sottocartelle in una cartella. 

io dovrei riassumere in questo file tutte le stesse celle provenienti dai vari file ed inserire il percorso linkabile(se possibile )  :

nome (A1)	cognome  (B20)	via (H45)	indirizzo ( ecc..)	dati	note	percorso
pippo	rossi	via rossi				//c:./..
gino	bianchi	via bianchi				//c../

Qualcuno mi può indicare come fare? e dove inserire la query e salvarla?

Grazie.

Answer 1

Ciao Seghezzi,

Se, nel file originario, non vedi alcun messaggio, la macro non è stata eseguita.

Visto che il codice funzioni nel modo previsto nel secondo file, per togliere tutti i messaggi, tranne quello del report finale, sostitiusci l'ultimo codice 'diagnostico' con la versione precedente.

Per avviare la macro in futuro, inserisci un pulsante dai controlli modulo e assegnalo la macro:

https://support.office.com/it-it/article/Aggiungere-un-pulsante-e-assegnare-una-macro-al-pulsante-in-un-foglio-di-lavoro-d58edd7d-cb04-4964-bead-9c72c843a283?CorrelationId=90305706-940c-4611-9f60-d53aece901fe&ui=it-IT&rs=it-IT&ad=IT

===

Regards,

Norman

Answer 2

sembra che sono a buon punto ma non capisco una cosa!

se faccio esegui Macro sul Riassuntivo.XLSM non compare nulla. vedi email precedente!

se invece salvo un nuovo file Riassuntivo.XLSX  ed ovviamente mi dice che non è possibile sallavareprogetti VBA 

una volta salvato eseguo macro:

mi si popola il file Riassuntivo.XLSM dandomi una serie di messaggi quanti sono i file importati.

Sono un pò impedito mi Sa!?!?

non riesco a venirne a capo!!

e per l'aggiornamento del file ?  metto un tasto con agganciata la macro?

Answer 3

Ciao Seghezzi,

dopo esegui test non mi esce nessun messaggio.

Questo non riesco a capire!!

Nel modo in cui ho scritto il codice, a patto che il codice venga eseguito, credo che si debba vedere sia il mio messaggio o un messagio di errore!

Posiziona il cursore all'interno della routine Tester e premi il tasto F5. Ti continua a vedere niente?

Prova a eseguire la seguente versione  del codice e fammi sapere cosa succede:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim oFSO As Object

    Dim oFolder As Object

    Dim oSubFolder As Object

    Dim oFile As Object

    Dim destSH As Worksheet, srcSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim arrIn As Variant, arrReport() As Variant

    Dim LRow As Long

    Dim i As Long, iCtr As Long, iButtons As Long

    Dim aStr As String

    Dim sStr As String, sMsg As String, sTitle As String

    Dim CalcMode As Long

    Const sPercorso As String = _

                               "C:\Users\NDJ\Italia"                     '<<===== Modifica

    Const sCartella As String = "Ordini"                           '<<===== Modifica

    Const sFileRiassuntivo As String = "Riassuntivo.xlsx"   '<<===== Modifica

    Const sFoglioRiassuntivo As String = "Riepilogo"        '<<===== Modifica

    Const sNomeFoglio As String = "Sheet1"                   '<<===== Modifica

    Const CelleDaCopiare As String = _

          "B28,B29,B8,B10,B2,B6,B19,B34,B35," _

          & "STATUS,B36,FILES VIEW"                               '<<===== Modifica

    arrIn = Split(CelleDaCopiare, ",")

    ReDim Preserve arrIn(1 To UBound(arrIn) + 1)

    Set destWB = Workbooks.Open(sPercorso & sFileRiassuntivo)

    Set destSH = destWB.Sheets(sFoglioRiassuntivo)

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = oFSO.GetFolder(sPercorso & sCartella)

    '\ On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    For Each oSubFolder In oFolder.Subfolders

        MsgBox oSubFolder.Path

        For Each oFile In oSubFolder.Files

            aStr = oFile.Path

            MsgBox aStr

            Application.StatusBar = "Riepilogando dati per " & aStr

            Set srcWB = Workbooks.Open(aStr)

            Set srcSH = srcWB.Sheets(sNomeFoglio)

            With destSH

                LRow = LastRow(destSH, .Columns("A:A"))

                Set destRng = .Range("A" & LRow + 1).Resize(1, UBound(arrIn))

            End With

            With srcSH

                For i = 1 To UBound(arrIn)

                    Select Case arrIn(i)

                    Case "STATUS"

                        destRng.Cells(i).Value = _

                        IIf(.Range("I2").Value > Now, "ACTIVE", "EXPIRED")

                    Case "FILES VIEW"

                        destSH.Hyperlinks.Add Anchor:=destRng.Cells(i), _

                                              Address:=aStr, _

                                              TextToDisplay:=srcWB.Name

                    Case Else

                        destRng.Cells(i).Value = .Range(arrIn(i)).Value

                    End Select

                Next i

            End With

            iCtr = iCtr + 1

            MsgBox iCtr

            ReDim Preserve arrReport(1 To iCtr)

            arrReport(iCtr) = aStr

            srcWB.Close SaveChanges:=False

        Next oFile

    Next oSubFolder

    destWB.Close SaveChanges:=True

    If CBool(iCtr) Then

        sStr = Join(arrReport, vbNewLine)

        sMsg = "I seguenti " _

             & iCtr _

             & " file sono stati riepologati:" _

             & vbNewLine & vbNewLine _

             & sStr

        iButtons = vbInformation

        sTitle = "REPORT"

    Else

        sMsg = "Nessun file è stato trovato - controlla il percorso!"

        iButtons = vbCritical

        sTitle = "CONTROLLA PERCORSO!"

    End If

    Call MsgBox(Prompt:=sMsg, Buttons:=iButtons, Title:=sTitle)

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

        .StatusBar = False

    End With

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

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

Nel frattempo ...

eccoti link 

https://onedrive.live.com/redir?resid=DA48F3C0B638BDFB!3087&authkey=!ABnzKapg3o3sJno&ithint=file%2cxlsx

Ho scaricato il tuo file e l'ho salvato  nella cartella A, una delle sottocartelle della cartella Ordine. Eseguendo poi il mio codice precedente, vedo il seguente messaggio:


Aprendo poi il file Riassuntivo.xlsx, vedo che anche i dati del tuo file 

ASL PALERMO 3500 new.xlsx sono stati riepilogati.


Quindi il problema non risiede nell'operazione di copia e non credo che ci sia un problema intrinseco nel mio codice.

Aspetterò le tue notizie prima di comprare un biglietto aereo!

[EDIT]

Ho aggiunto uno screenshot del file Riassuntivo.xlsx.

===

Regards,

Norman