Macro che copia da piu cartelle in un foglio

[tav]

Ciao tutti sono qua ancora a chiedere un vostro aiuto perché non riesco a venirne a capo e trovare nessuna soluzione.

Io in un percorso  "N:\Direzione Supply Chain\Corporate Customer Service\Condivisa con altri enti\SIM\ " ho all'interno 10 sotto cartelle ( di cui solo 9 con all'interno un file a cui dovrei fare il merge delle informazioni).

Mi piacerebbe capire come creare una macro che mi permetta di ricercare all'interno delle sottocartelle il file con nome SIM data odierna ( esempio SIM 22-05-2018). Tutti i file hanno estensione .xlsm.
Una volta trovati i file nelle varie cartelle, mi piacerebbe che i file venissero copiati dalla riga 6 e messi tutti in un unico foglio nuovo (incollando dalla riga 2)

Allego due file che sono all'interno delle cartelle.

https://we.tl/MDVMYI6ajT

Grazie per l'aiuto
non so proprio da dove iniziare ed ho guardato un macello di post

[Anthony47]

Nove percorsi non e' una enormita', per cui suggerisco ancora di usare la Function MonoDirXlsm di quest'altra discussione: viewtopic.php?f=26&t=109690#p643619

Richiamerai poi questa funzione in modo simile a quanto gia' suggerito (vedi Sub Pulsante1_Click), con la sola variante di questa riga:

Codice: Seleziona tutto

Filtr = "SIM " & Format(Now, "dd-mm-yyyy") & ".xlsm"       '<<< Modificata

La Function MonoDirXlsm ti restituira' il numero di file trovati e (in FArr) l'elenco dei file.

Ora non ti resta che
-creare un foglio nuovo
-aprire uno file alla volta, accedere al foglio che ti interessa, copiarlo fino a file elenco, incollarlo sul foglio appena creato accodandolo all'esistente. Il codice che fa questo:

Codice: Seleziona tutto

Dim tdWs As Worksheet, mioFile As String
Set tdWs = Worksheets.Add
'
For I = 1 To NumF
    mioFile = FArr(I)
    If mioFile <> "" Then
        Workbooks.Open mioFile, 0
        Sheets(1).Select            '<<< Il numero o nome del foglio
        Range(Range("A6"), Range("A6").End(xlDown)).Resize(, 18).Copy tdWs.Cells(tdWs.Rows.Count, 1).End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close False
    End If
Next I

Va accodata alla nuova Sub Pulsante1_Click (o come vorrai chiamarla), al posto della riga "Qui il codice per processare i file individuati"

Metti sia il codice della Function MonoDirXlsm e della nuova Sub Pulsante1_Click (o come vorrai chiamarla...) in un Modulo vba standard del tuo file di lavoro.

Fai sapere se ti e' chiaro e riesci a procedere...

[tav]

Ciao Anthony
grazie.
Mi da un errore di run time 52 "nome o numero non valido" sulla function in questo punto
myF = Dir(ccDir & myFilt)

cosa significa?


Edit:
Ho spostato i messaggi da viewtopic.php?f=26&t=109690 a viewtopic.php?f=26&t=109769 (dove e' stato pubblicato il suggerimento a cui questi messaggi fanno seguito)
Anthony

[tav]

ok ho sistemato il problema .
Mi riesci a spiegare un attimo con funziona il ciclo for per processare il singolo nome file.
fa il passaggio della cartella trova il file e poi io tramite un'istruzione di copia incolla lo faccio inserire all'interno del mio file di output?

[tav]

unico problema è come fare a dirgli una volta che hai copiato tutte le righe del primo percorso ( dalla riga A6), passare al secondo percorso e incollarle sotto a quelle gia copiate?

[Anthony47]

Mi riesci a spiegare un attimo con funziona il ciclo for per processare il singolo nome file.
fa il passaggio della cartella trova il file e poi io tramite un'istruzione di copia incolla lo faccio inserire all'interno del mio file di output?

unico problema è come fare a dirgli una volta che hai copiato tutte le righe del primo percorso ( dalla riga A6), passare al secondo percorso e incollarle sotto a quelle gia copiate?

Come detto, nella matrice FArr vengono memorizzati tramite la Function MonoDirXlsm il percorso e nome dei file interessati.
Nella fase successiva:
-si aggiunge un Foglio
-Si scansiona il contenuto di FArr (loop For I = 1 To NumF / Next I); si apre il file; se ne copia il contenuto da A6 verso il basso, colonne A:R; si accoda al foglio appena aggiunto; si chiude il file appena aperto.

Questo e' gia' fatto col codice suggerito

Quanto all'errore run time 52 "nome o numero non valido", sarebbe utile per chi legge sapere quale era l'origine.

Ciao

[tav]

Grazie Anthony ora mi è chiaro. volevo capire il procedimento.
L'errore che mi dava era dovuto che da vpn faceva fatica a girare. appena l'ho fatto girare in ufficio non mi ha dato nessun oproblema.

ti chiedo un'ultima cortesia. come faccio a duplicare una riga? cioè mi spiego meglio, io vorrei duplicare la riga se e solo se nella colonna j e nella colonna L c'è un valore diverso da vuoto. in caso le due celle non fossero vuote vorrei che mi si duplicasse la riga per intera e in una venga scritta solo con il valore contenente in j,k e nell'altra tutta la riga e solo il valore in L,M.


Avevo pensato ad un ciclo for che leggesse tutto il file con all'interno un if con doppia condizione, ma poi come faccio a far duplicare la riga nel modo sopra indicato? l'output deve andare su un altro foglio?

[tav]

Stavo rileggendo l’ultima mia risposta è ho omesso una cosa. Vorrei duplicare la riga solo se le due colonne j e k non sono nulle, ma nella riga duplicata vorrei che mi scrivesse solo quella della posizione k nella nuova posizione j ( in modo da averla allineata a quella precedente)

[Anthony47]

Ovviamente mettersi a guardare le righe una per una per capirne il contenuto complica alquanto la macro, e comunque per me l'ultimo messaggio invece di chiarire confonde.

Allora tu invece di copiare in blocco il contenuto del FoglioX del file che viene aperto e accodarlo al foglio appena aggiunto vuoi esaminare uno per uno i recor presenti; se ambedue J e K hanno un contenuto quella riga va inserita due volte; ecco, nella prima occorrenza mi sembra che vada la riga cosi' come e' (quindi tutte le sue 18 colonne), ma nella seconda?

Ciao

[tav]

Eh lo so è difficile da spiegare. Vorrei che nella prima riga mi escludesse le colonne k e m e copiasse tt il resto. Mentre nella seconda spostasse il valore di k nella colonna j in modo di avere allineato tutto nel modo corretto

[Anthony47]

Allora il ciclo centrale potrebbe essere modificato come segue:

Codice: Seleziona tutto

For I = 1 To NumF
    mioFile = fArr(I)
    If mioFile <> "" Then
        Workbooks.Open mioFile, 0
        Sheets(1).Select            '<<< Il numero o nome del foglio
        nextI = tdWs.Cells(tdWs.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        For K = 6 To Cells(Rows.Count, 1).End(xlUp).Row
            If Cells(K, "J") <> "" And Cells(K, "K") <> "" Then
                Cells(K, 1).Resize(1, 18).Copy tdWs.Cells(nextI, 1): nextI = nextI + 1
                Cells(K, 1).Resize(1, 18).Copy tdWs.Cells(nextI, 1)
                tdWs.Cells(nextI, "J").Value = tdWs.Cells(nextI, "K").Value
                tdWs.Cells(nextI, "K").ClearContents: nextI = nextI + 1
            Else
                Cells(K, 1).Resize(1, 18).Copy tdWs.Cells(nextI, 1): nextI = nextI + 1
            End If
        Next K
        Range(Range("A6"), Range("A6").End(xlDown)).Resize(, 18).Copy tdWs.Cells(tdWs.Rows.Count, 1).End(xlUp).Offset(1, 0)
        ActiveWorkbook.Close False
    End If
Next I


Pero' non capisco che senso ha copiare col K (che e' un numero, nel tuo file pubblicato) nella colonna J (che e' una data).

Ciao

[tav]

Ciao Anthony
Dovrei riaprire il topic perché mi sono accorto di un problema che non riesco a risolvere.
Quando mi si presenta un file da compattare con una sola riga la macro mi da un errore del tipo tabella di diverse dimensioni. Se invece il file ha più di una riga non mi crea problemi. L’errore è sul Range(A6) alla fine della macro

[tav]

Ciao Anthony
Dovrei riaprire il topic perché mi sono accorto di un problema che non riesco a risolvere.
Quando mi si presenta un file da compattare con una sola riga la macro mi da un errore del tipo tabella di diverse dimensioni. Se invece il file ha più di una riga non mi crea problemi. L’errore è sul Range(A6) alla fine della macro

l'errore lo da su questa formula Range(Range("A6"), Range("A6").End(xlDown)).Resize(, 18).Copy tdWs.Cells(tdWs.Rows.Count, 1).End(xlUp).Offset(1, 0) solo nel caso ci sia solo una riga segnalata nel file

[Anthony47]

Allora sostituisci la riga Range(Range("A6"), Range("A6").End(xlDown)).Resize(, 18).Copy tdWs.Cells(tdWs.Rows.Count, 1).End(xlUp).Offset(1, 0) con

Codice: Seleziona tutto

        laa = Cells(Rows.Count, "A").End(xlUp).Row
        Range("A6").Resize(laa - 5, 18).Copy tdWs.Cells(tdWs.Rows.Count, 1).End(xlUp).Offset(1, 0)

Ciao

[tav]

Grazie