Creare file copiando RANGE da files esterni

[BG66]

Ciao a tutti,
grazie ad Anthony è stato risolto il thread precedente:
http://www.pc-facile.com/forum/viewtopic.php?f=26&t=108584

Ma vista la complessità dello script NON riesco a capire dove modificarlo per adatarlo ad una nuova esigente.

Codice: Seleziona tutto

Sub MeseImport()
Dim DBPath As String, myCFile As String, mySplit, mySh As String, myD As Date, myT As String
Dim I As Long, mErr As String, dbSh As Worksheet, myLast As Long, daImp, myMatch
'
DBPath = "D:\FORNI_2017\GIUGNO"                 '<<< La directory da cui importare
daImp = Array("T09", "T10", "T11", "T12")       '<<< L'elenco dei forni da importare
'
mySplit = Split(DBPath, "\", , vbTextCompare)
mySh = "DataBase_" & Format(CDate("01/" & mySplit(UBound(mySplit)) & "/" & Right(mySplit(UBound(mySplit) - 1), 4)), "MmmYY")
Sheets(mySh).Select
If Right(DBPath, 1) <> "\" Then DBPath = DBPath & "\"
Set dbSh = ThisWorkbook.Sheets(mySh)
'Azzera l'area di importazione:
Range("A2:C20000,E2:G20000").ClearContents
'Importa:
myCFile = Dir(DBPath & "*.xls*")
Do
myMatch = Application.Match(Left(myCFile, 3), daImp, 0)
Application.ScreenUpdating = False
    If myCFile = "" Then Exit Do
    If Not IsError(myMatch) Then
        On Error Resume Next
    Debug.Print myCFile, Timer
        Workbooks.Open Filename:=(DBPath & myCFile), UpdateLinks:=False, ReadOnly:=True
        On Error GoTo 0
        If ActiveWorkbook.Name = ThisWorkbook.Name Then
            mErr = mErr & vbCrLf & DBPath & myCFile
        Else
            Sheets(1).Select
            For I = 5 To Cells(Rows.Count, 1).End(xlUp).Row + 50
    '        Debug.Print I, Timer
            DoEvents
                myLast = dbSh.Cells(Rows.Count, 1).End(xlUp).Row
                myD = Cells(I, 1).MergeArea.Range("A1").Value
                If myD > Int(Now) Then Exit For
                myT = Cells(I, 2).MergeArea.Range("A1").Value
                If myT <> "" Then
                    If myD = dbSh.Cells(myLast, 1) And myT = dbSh.Cells(myLast, 3) Then
                        dbSh.Range("E" & myLast).Value = dbSh.Range("E" & myLast).Value + Cells(I, "L").Value
                        dbSh.Range("F" & myLast).Value = dbSh.Range("F" & myLast).Value + Cells(I, "O").Value
                        dbSh.Range("G" & myLast).Value = dbSh.Range("G" & myLast).Value + Cells(I, "P").Value
                    Else
                        myLast = myLast + 1
                        dbSh.Cells(myLast, "A").Value = myD
                        dbSh.Cells(myLast, "B").Value = ActiveSheet.Name
                        dbSh.Cells(myLast, "C").Value = myT
                        dbSh.Cells(myLast, "E").Value = Cells(I, "L").Value
                        dbSh.Cells(myLast, "F").Value = Cells(I, "O").Value
                        dbSh.Cells(myLast, "G").Value = Cells(I, "P").Value
                    End If
                End If
            Next I
        Workbooks(myCFile).Close False
        Application.ScreenUpdating = True: DoEvents
        End If
    Else
        Beep
    End If
    myCFile = Dir
Loop
Application.ScreenUpdating = True
If Len(mErr) > 3 Then
    MsgBox ("Completato, eccetto i seguenti file:" & vbCrLf & mErr)
Else
    MsgBox ("Completato")
End If
End Sub


In pratica và tutto bene tranne che quando è il momento di copiare i dati in Masterdata i valori da prelevare sono tutti quelli da colonna A a colonna AE (escludendo le colonne E - F).

Tutte le prove fatte finora hanno solo causato un superlavoro al DEBUG .

Grazie in anticipo.

[Anthony47]

Purtroppo quello che dici (i valori da prelevare sono tutti quelli da colonna A a colonna AE, escludendo le colonne E - F) non e' esaustivo perche' non si sa quali colonne da importare sono celle unite e quali no.

Quindi serve un esempio di file da importare, col suo layout.
Dovresti anche spiegare se le posizione su Masterdata sono contigue o se anche li bisogna saltare le colonne E-F.

Ciao

[BG66]

Ciao Anthony,
nessun salto in Masterdata.

File sorgente:
https://www.dropbox.com/s/1ep7vj8g65sm319/T09_GENNAIO_2017%28anthony%29.xls?dl=0

Grazie per l'aiuto

[Anthony47]

Allora...
Nella vecchia Sub MeseImport sostituisci tutta la parte If myT <> "" Then /End If con questo nuovo codice:

Codice: Seleziona tutto

                If myT <> "" Then
                    If myD = dbSh.Cells(myLast, 1) And myT = dbSh.Cells(myLast, 3) Then
                        k = 3
                        For j = 3 To Range("AE1").Column
                            If j <> 5 And j <> 6 Then
                                dbSh.Cells(myLast, j) = dbSh.Cells(myLast, j) + Cells(I, k)
                                k = k + 1
                            Next j
                        Next j
                    Else
                        myLast = myLast + 1
                        dbSh.Cells(myLast, "A").Value = myD
                        dbSh.Cells(myLast, "B").Value = ActiveSheet.Name
                        dbSh.Cells(myLast, "C").Value = myT
                        k = 3
                        For j = 3 To Range("AE1").Column
                            If j <> 5 And j <> 6 Then
                                dbSh.Cells(myLast, j) = Cells(I, k)
                                k = k + 1
                            Next j
                        Next j
                    End If
                End If


Prova e fai sapere...

[BG66]

Ciao Anthony,
ho provato qualche giorno a risolverlo da solo.... ma non ci sono riuscito.

[Anthony47]

Niente di grave, e' una "semplice cappellata" Non avendo un testbed su cui provare ho lavorato sulla carta, ma ho appunto "cappellato".
Nella macro ci sono due sequenze del tipo
k = k + 1
Next j
Next j
Il primo dei due Next J deve essere (in ambedue i blocchi) un End If:

Codice: Seleziona tutto

                                k = k + 1
                            End If 'ERRATO: Next j
                        Next j

Riprova e saro' piu' fortunato

Ciao

[BG66]

Ciao Anthony,
mi sono incartato e forse anche perso


Se vuoi controllare:
File sorgente:
https://www.dropbox.com/s/1ep7vj8g65sm319/T09_GENNAIO_2017%28anthony%29.xls?dl=0

File destinatario:
https://www.dropbox.com/s/br2a1xd5tilukrk/masterdata_2017_v1An.xlsm?dl=0

Grazie se puoi.

[Anthony47]

Sono in viaggio quindi non riesco a fare prove.

Non hai detto perche' ti sei incartato, se e' un problema di comprensione o di errore.
Comunque vedo che imposti DBPath="C:\Users\Microsoft\Desktop\Progetti Excel\archivio master\2017"; ma la macro si aspetta anche il mese; quindi esempio "..... archivio master\2017\giugno". Questo perche' i file (anche se hanno il mese nel nome del file) erano (nella discussione precedente) archiviati in una directory col nome mese.
L'istruzione che hai ingiallito usa gli ultimi due termini del percorso per creare il nome del foglio DataBase_MMMyy su cui lavorare. Mancando il mese immagino che avrai poi un errore e comunque il nome foglio non puo' essere calcolato correttamente.

Ricordo altri prerequisiti, sempre dalla discussione precedente:
1) Il file Masterdata deve gia' contenere un foglio nominato come DataBase_mmmYY
Dove "mmm" e' il mese (3 lettere) e YY e' l'anno (2 cifre)
2) Il file che si va ad aprire contiene i dati da importare nel primo fo
glio; il nome di questo foglio verra' importato in colonna B di Masterdata
3) Le prime 3 lettere del nome file identificano il nome dell'impianto

Quindi prova ancora e fai sapere.

Ciao

[BG66]

Ciao Anthony,

...

Non hai detto perche' ti sei incartato, se e' un problema di comprensione o di errore.

scusami mi sono fatto prendere dallo sconforto. Speravo di essere un pò più autonomo ma non è cosi.
Infatti anche questa differenza mi ha trovato impreparato

Dalla prove fatte nasce dopo la modifica:

Nella vecchia Sub MeseImport sostituisci tutta la parte If myT <> "" Then /End If con questo nuovo codice:

...
Comunque vedo che imposti DBPath="C:\Users\Microsoft\Desktop\Progetti Excel\archivio master\2017"; ma la macro si aspetta anche il mese; quindi esempio "..... archivio master\2017\giugno". Questo perche' i file (anche se hanno il mese nel nome del file) erano (nella discussione precedente) archiviati in una directory col nome mese.

Hai ragione, quella era una delle tante prove per capire cosa sbagliavo.... in realtà mettevo sempre una \ di troppo alla fine del percorso.

Grazie per la pazienza e disponibilità

[Anthony47]

Questa macro e' nata male e continua male, e uno dei motivi e' l'impossibilita' a collaudare una macro che dovrebbe mettere nel file Masterdata il contenuto di un file vuoto (perche' "vuoto" e' il file di test che hai pubblicato)
Comunque ci sono "un paio" di errori ulteriori:
nel loop il valore iniziale di K e J deve essere 4 e non 3
nel loop i valori di K e J sono usati all'inverso

Tuttavia ci sono anche cose che non mi quadrano; in particolare la macro dovrebbe creare una sintesi di quanto presente nei fogli tipo T09_GENNAIO_2017, sommando i dati che appartengono allo stesso giorno e allo stesso turno.
Ma nel file di prova pubblicato alcune colonne tra quelle da trattare (da colonna A a colona AE escluse E-F) contengono Stringhe (es G ed N), e la formula di colonna N in numerosi casi segnala #Valore. In questa situazione fare "somme" diventa aleatorio, e quindi ho aggiunto nella macro alcuni controlli che le celle non siano o non provochino errori; ma secondo me c'e' qualcosa di sbagliato a monte (oppure hai distribuito un file di prova errato).

Con queste correzioni e questi dubbi la macro e' questa:

Codice: Seleziona tutto

Sub MeseImport3()
Dim DBPath As String, myCFile As String, mySplit, mySh As String, myD As Date, myT As String
Dim I As Long, mErr As String, dbSh As Worksheet, myLast As Long, daImp, myMatch
'
DBPath = "D:\FORNI_2017\GENNAIO"                 '<<< La dir da cui importare
daImp = Array("T09", "T10", "T11", "T12")       '<<< L'elenco dei forni da importare
'
mySplit = Split(DBPath, "\", , vbTextCompare)
mySh = "DataBase_" & Format(CDate("01/" & mySplit(UBound(mySplit)) & "/" & Right(mySplit(UBound(mySplit) - 1), 4)), "MmmYY")
Sheets(mySh).Select
If Right(DBPath, 1) <> "\" Then DBPath = DBPath & "\"
Set dbSh = ThisWorkbook.Sheets(mySh)
'Azzera l'area di importazione:
Range("A2:C20000,E2:G20000").ClearContents
'Importa:
myCFile = Dir(DBPath & "*.xls*")
Do
myMatch = Application.Match(Left(myCFile, 3), daImp, 0)
Application.ScreenUpdating = False
    If myCFile = "" Then Exit Do
    If Not IsError(myMatch) Then
        On Error Resume Next
    Debug.Print myCFile, Timer
        Workbooks.Open Filename:=(DBPath & myCFile), UpdateLinks:=False, ReadOnly:=True
        On Error GoTo 0
        If ActiveWorkbook.Name = ThisWorkbook.Name Then
            mErr = mErr & vbCrLf & DBPath & myCFile
        Else
            Sheets(1).Select
            For I = 5 To Cells(Rows.Count, 1).End(xlUp).Row + 50
    '        Debug.Print I, Timer
            DoEvents
                myLast = dbSh.Cells(Rows.Count, 1).End(xlUp).Row
                myD = Cells(I, 1).MergeArea.Range("A1").Value
                If myD > Int(Now) Then Exit For
                myT = Cells(I, 2).MergeArea.Range("A1").Value
                If myT <> "" Then
                    If myD = dbSh.Cells(myLast, 1) And myT = dbSh.Cells(myLast, 3) Then
                        K = 4
                        For J = 4 To Range("AE1").Column
                            If J <> 5 And J <> 6 And Not IsError(Cells(I, J)) Then
                                dbSh.Cells(myLast, K) = Val(dbSh.Cells(myLast, K)) + Val(Cells(I, J))
                                K = K + 1
                            End If 'Next j
                        Next J
                    Else
                        myLast = myLast + 1
                        dbSh.Cells(myLast, "A").Value = myD
                        dbSh.Cells(myLast, "B").Value = ActiveSheet.Name
                        dbSh.Cells(myLast, "C").Value = myT
                        K = 4
                        For J = 4 To Range("AE1").Column
                            If J <> 5 And J <> 6 And Not IsError(Cells(I, J)) Then
                                dbSh.Cells(myLast, K) = Val(Cells(I, J))
                                K = K + 1
                            End If 'Next j
                        Next J
                    End If
                End If
            Next I
        Workbooks(myCFile).Close False
        Application.ScreenUpdating = True: DoEvents
        End If
    Else
        Beep
    End If
    myCFile = Dir
Loop
Application.ScreenUpdating = True
If Len(mErr) > 3 Then
    MsgBox ("Completato, eccetto i seguenti file:" & vbCrLf & mErr)
Else
    MsgBox ("Completato")
End If
End Sub

Ri-riprova anche tu...

[BG66]

Ciao Anthony,
i miei tentativi di confonderti sono risultati vani ....Obiettivo raggiunto.
E studiando il tutto sono riuscito ad adattarla al master...

Grazie per la pazienza e alla prossima.