Help: Macro di raccolta informazioni da diversi fogli di file excel

Question

Ciao a tutti,

avrei bisogno di un aiuto per creare una delle mie prime macro!

Provo a spiegarmi nel dettaglio:

Nella cartella C:\Users\Dan\Desktop\DatiOperativi sono presenti files excel che fungono da DataBase, i cui nomi identificano il mese e l'anno di riferimento; ad oggi ad esempio ho:

201401.xls

20102.xls

201403.xls

Ognuno di questi file possiede tanti fogli quanti sono i giorni del mese fino ad oggi trascorsi, moltiplicati per tre (vengono implementati di giorno in giorno). Ad esempio, se oggi fosse il 3 marzo 2014, avrei 9 fogli con i seguenti nomi: 01_15 , 01_17 , 01_20 , 02_15 , 02_17 , 02_20 , 03_15 , 03_17 , 03_20 .

Tutti i fogli hanno la stessa struttura, e in ogni foglio sono interessato ad estrarre i dati contenuti nelle celle B10, B15, C13, D20.

Quello che mi servirebbe è una macro posta nel file excel analisi.xls (che si trova nella stessa cartella) che lavori sul foglio denominato "upload".

In questo foglio a partire dalla 3°riga ho precompilate le prime due colonne: la colonna A è compilata con il un numero che identifica il file Database (ad esempio 201401,201402 e così via) la colonna B identifica il nome del foglio (ad esempio 01_15, 01_17, ...) in cui si devono cercare i 4 valori delle celle indicate sopra ( B10, B15, C13, D20).

Scopo della macro sarà quello di andare a compilare le colonne C, D, E, F con questi valori.

Per far questo, la Macro appena lanciata dovrebbe chiedermi "da quale file database devo estrarre?", dandomi la possibilità di scegliere 201401.xls ,201402.xls e così via.

La macro non deve cancellare i valori scritti da precedenti estrazioni ma deve andare a riempire le righe corrispondenti ai fogli dei giorni che non erano ancora presenti nel file database (201401,201402,...).

Ringrazio anticipatamente chiunque possa darmi una mano.

DV

Answer 1

Ti ringrazio Norman per i suggerimenti,

ho provato ad installare l'add-in ma una volta che mi compare il pulsante dedicato nel browser "DATI", cliccando su RDBMerge Add-in non succede niente (non mi compare la finestra che è indicata nelle istruzioni).

Come posso fare?

Ciao Daniele,

Prova qualcosa del genere:

Alt-F11 per aprire l'editor di VBA

Alt-IM per inserire un nuovo modulo di codice

Nel nuovo modulo vuoto, incolla il seguente codice:

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

Option Explicit

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

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim rngFiles As Range, rCell As Range

    Dim arrFiles As Variant

    Dim arrIn() As Variant

    Dim Res As Variant

    Dim sStr As String, aStr As String

    Dim iLastRow As Long, jLastRow As Long, iRows As Long

    Dim i As Long, j As Long, k As Long, p As Long

    Dim iVal As Long, iButtons As Long

    Dim sSheetName As String, sFileName As String, sPath As String

    Dim sMsg As String, sTitle As String

    Dim CalcMode As Long

    Dim blValidFormat As Boolean, blError As Boolean

    Const sAddress As String = "B10, B15, C13, D20"

    On Error GoTo ErrHandler

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    Set destWB = Workbooks("Analisi.xls")

    sStr = Format(Date, "yyyy")

    aStr = Format(Date, "mm")

    Res = VBA.InputBox(Prompt:="Inserisci il nome del file da quale devo " _

                               & "estrarre dei dati" _

                               & vbNewLine _

                               & "Sostituisci le ultime due cifre con " _

                               & "quelle del mese di interessa", _

                       Title:="Scegliere Database", Default:=sStr & aStr)

    If Res Like sStr & "##" Or Res Like CLng(sStr) - 1 & "##" Then

        iVal = Right(Res, 2)

        If iVal > 0 And iVal <= 12 Then

            blValidFormat = True

            sPath = destWB.Path

            sFileName = sPath & Format(Date, "yyyy") & Res & ".xls"

        End If

    End If

    If Not blValidFormat Then

        If StrPtr(Res) = 0 Then

            sMsg = "Hai cancellato!"

            iButtons = vbInformation

            sTitle = "Alla prossima!"

        Else

            If Len(Res) = 0 Then

                sMsg = "Non hai inserito niente"

                iButtons = vbCritical

                sTitle = "Valore vuoto!"

            Else

                sMsg = "Hai inserito il valore " & Res _

                       & vbNewLine & "Si aspettava un nome di file nella forma" _

                       & vbNewLine _

                       & "yyyymm - ad esempio " & sStr & aStr

            End If

        End If

        GoTo XIT

    End If

    Set destSH = destWB.Sheets("Upload")

    With destSH

        iLastRow = LastRow(destSH, .Columns("C:C"))

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

        Set rngFiles = .Range("A" & iLastRow + 1, "B" & jLastRow)

    End With

    arrFiles = rngFiles.Value

    iRows = UBound(arrFiles, 1)

    ReDim arrIn(1 To iRows, 1 To 3)

    For i = 1 To iRows

        If arrFiles(i, 1) = CLng(Res) Then

            If CLng(Left(arrFiles(i, 2), 2)) <= Day(Date) + 3 Then

                j = j + 1

                arrIn(j, 1) = arrFiles(i, 1)

                arrIn(j, 2) = arrFiles(i, 2)

                arrIn(j, 3) = rngFiles.Cells(i, 3).Address

            End If

        End If

    Next i

    arrIn = Application.Transpose(arrIn)

    ReDim Preserve arrIn(1 To 3, 1 To j)

    arrIn = Application.Transpose(arrIn)

    Set srcWB = Workbooks.Open(arrIn(1, 1) & ".xls")

    For k = 1 To UBound(arrIn, 1)

        p = 0

        sSheetName = arrIn(k, 2)

        Set srcSH = srcWB.Sheets(sSheetName)

        destSH.Activate

        Set srcRng = srcSH.Range(sAddress)

        Set destRng = destSH.Range(arrIn(k, 3))

        For Each rCell In srcRng.Cells

            p = p + 1

            destRng.Offset(0, p - 1).Value = rCell.Value

        Next rCell

    Next k

    srcWB.Close Savechanges:=False

XIT:

    On Error GoTo 0

    If Not blValidFormat Then

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

    End If

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

    If Not blError And blValidFormat Then

        Call MsgBox(Prompt:="Tutto Fatto senza errore", _

                    Buttons:=vbInformation, _

                    Title:="Finito ")

    End If

    Exit Sub

ErrHandler:

    blError = True

    Call MsgBox(Prompt:="Error " _

                        & Err.Number _

                        & " (" _

                        & Err.Description _

                        & ") nella routine: Tester", _

                Buttons:=vbCritical, _

                Title:="ERRORE")

    Resume XIT

End Sub

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

Function LastRow(SH As Worksheet, _

                 Optional Rng As Range)

    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

End Function

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

Alt-Q per chiudere l'editor di VBA

Alt-F8 per aprire la finestrina macro

Seleziona Tester | Esegui

Perché non ho avuto i tuoi dati o cartelle di lavoro per aiutarmi, ho dovuto fare alcune ipotesi. Pertanto, ti consiglio  vivamente di eseguire il codice suggerito su una copiadel file Analysis.xls. In ogni caso, questo è sempre buona pratica con il nuovo codice. Le altre cartelle di lavoro non sono alterati in alcun modo dal mio codice e possono quindi essere utilizzati nei test.

===

Regards,

Norman

Answer 2

Ciao Daniele,

Ti ringrazio per il riscontro.

Vorrei approfittare per attirare la tua attenzione sulla riga evidenziata in grassetto:

    For k = 1 To UBound(arrIn, 1)

        p = 0

        sSheetName = arrIn(k, 2)

        Set srcSH = srcWB.Sheets(sSheetName)

destSH.Activate

        Set srcRng = srcSH.Range(sAddress)

        Set destRng = destSH.Range(arrIn(k, 3))

        For Each rCell In srcRng.Cells

            p = p + 1

            destRng.Offset(0, p - 1).Value = rCell.Value

        Next rCell

    Next k

Questa riga non serve alcuno scopo tranne che per un test che ho voluto effettuare prima di postare il codice. Questa riga può, e dovrebbe, essere eliminata. In generi, la selezione di un oggetto in VBA è da evitare e questo non è un'eccezione!

Il fatto che una tale riga di codice  dovrebbe manifestarsi in codice postato da me è forse la miglior prova che il calendario non mente e che oggi è veramente il primo giorno di aprile :-)

Saluti!

===

Regards,

Norman

Answer 3

Grazie tante Norman!

Answer 4

Ti ringrazio Norman per i suggerimenti,

ho provato ad installare l'add-in ma una volta che mi compare il pulsante dedicato nel browser "DATI", cliccando su RDBMerge Add-in non succede niente (non mi compare la finestra che è indicata nelle istruzioni).

Come posso fare?

Grazie

DV

Answer 5

Ciao Daniele,

Considera l'utilizzo dell'add-in (componente aggiuntivo)  RDBMerge di Ron de Buin che può essere scaricato al seguente indirizzo:

                http://www.rondebruin.nl/win/winfiles/RDBMerge.zip

In alternativa, guarda l estesa scelta di codice di esempio di Ron de Bruin a:

              http://www.rondebruin.nl/win/section3.htm

Se dovessi incontrare dei problemi insuperabili, siamo qui per aiutarti. In tal caso, sarebbe utile se potessi includere degli screenshot o, meglio, scaricare dei file con dati di esempio (senza detagli sensibili)  su un servizio del tipo OneDrive o DropBox e poi postare il link in una risposta qui. 

===

Regards,

Norman