accodare dati da più file XLS o csv in un file di riepilogo

Question

Ciao a tutti.

Mi servirebbe una macro che mi faccia selezionare alcuni file presenti in una sottocartella chiamata: “da importare". I file da cui devo prelevare i dati hanno i dai nel range colonne A-E comprese e non sono formattati come tabelle, La prima riga è sempre l'intestazione. Il numero di righe non è fisso (da 2 a ~15).

Vorrei che mi accodasse i dati in un file unico posto in una cartella diversa dai file origine. e che mi scrivesse, ad esempio nel foglio 2, i file che sono stati usati.

Spero nel  vs. aiuto.

ps: excel 2016, mia conoscenza VBA: bassa

Answer 1

questo è quello che sono riuscito a fare e che funziona, se non ho file multipli di Excel aperti.

Il problema è che non riesco ad adattarlo alle mie esigenze. Mi serve in sostanza anche che sia possibile specificare un range di date su due celle (o su una message box) al fine di unire solo i dati in un range di date (data presente nella prima colonna). Inoltre potrebbero esserci dei dati duplicati nelle righe di più file. Mi servirebbe che i dati aggregati venissero ordinati per data (prima colonna , non è detto che nei file selezionati siano già in ordine) e che venissero eliminati i duplicati.

Option Explicit

Sub ztest_Unione_dati_su_unico_file()

Dim wksDest As String

    Dim shDest As Worksheet

    Dim FD As FileDialog, File As Variant, j As Byte, FR As Integer

    wksDest = ActiveWorkbook.Name

    Set FD = Application.FileDialog(msoFileDialogFilePicker)

    Application.ScreenUpdating = False

    With FD

        .AllowMultiSelect = True

        .Show

            For Each File In .SelectedItems

            Workbooks.Open File

            Worksheets(1).Range("a2", Worksheets(1).Range("a2").End(xlDown).Offset(-1, 0).End(xlToRight)).Select

            Selection.Copy

            Workbooks(2).Activate

            FR = [a1].CurrentRegion.Rows.Count + 1

    Application.ScreenUpdating = True

            Range("a" & FR).PasteSpecial xlPasteAll 'incolla la tabella dei valori

            Application.CutCopyMode = False

    Application.ScreenUpdating = False

            Workbooks(3).Close savechanges:=False                '==> qui il problema è che se ho più file Excel aperti mi

                                                                                                     'chiude quello sbagliato e non il file da cui ha

                                                                                                     'appena copiato i dati

            Next

    End With

    Application.ScreenUpdating = True

End Sub

Allego via gdrive il link dei file che devo importare in unico file.

file 1

file 2

Answer 2

Ciao

Scusa il ritardo ma non ho avuto modo di testare la tua proposta prima.

Il codice lascia il foglio "cdc unione file.xlsm" vuoto.

    Const sPercorso As String = _

          "D:\_ doc daniele\banca\ing\movimenti cdc singoli mesi\da importare"                  '<<=== Modifica

    Const sRiepilogo As String = "foglio1"              '<<=== Modifica

    Const sElencoFile As String = "File-Sorgenti"        '<<=== Modifica

    Const sNameType As String = "*.xls"                   '<<=== Modifica

    Const sIntervalloDati As String = "A2:E15"           '<<=== Modifica

Ho impostato come sopra: ho alcune domande:

1    sPercorso = percorso file sorgenti?

2    sElencoFile = elenco file da importare? = credo che il codice seguente mi eviti di scrivere a mano i nomi dei file

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = oFSO.GetFolder(sPercorso)

    Set oFiles = oFolder.Files

3    Const sNameType As String = "*.xls" : se necessitassi di importare sia xls che csv sarebbe possibile? (non è fondamentale ma sarebbe figo)

Ho provato a posizionare il file XLM sia dentro la cartella dei fil sorgenti che fuori senza successo.

Grazie mille

Answer 3

Ciao Daniele,

Mi servirebbe una macro che mi faccia selezionare alcuni file presenti in una sottocartella chiamata: “da importare". I file da cui devo prelevare i dati hanno i dai nel range colonne A-E comprese e non sono formattati come tabelle, La prima riga è sempre l'intestazione. Il numero di righe non è fisso (da 2 a ~15).

Vorrei che mi accodasse i dati in un file unico posto in una cartella diversa dai file origine. e che mi scrivesse, ad esempio nel foglio 2, i file che sono stati usati.

Spero nel  vs. aiuto.

ps: excel 2016, mia conoscenza VBA: bassa

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 oFSO As Object

    Dim oFile As Object

    Dim oFiles As Object

    Dim oFolder As Object

    Dim srcWb As Workbook, destWB As Workbook

    Dim srcSH As Worksheet

    Dim destSH As Worksheet, destSH2 As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim arrIn() As Variant, arrFilename() As Variant

    Dim arrHeaders() As Variant

    Dim sFilename As String

    Dim iCtr As Long, jCtr As Long, kCtr As Long

    Dim i As Long, j As Long

    Dim iRows As Long, iCols As Long

    Dim LRow As Long, LCol As Long

    Dim sName As String

    Const sPercorso As String = _

          "**C:\Users\Daniele\File_Sorgenti**"                  '<<=== Modifica

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

    Const sElencoFile As String = "File-Sorgenti"       '<<=== Modifica

    Const sNameType As String = "*.xlsx"                   '<<=== Modifica

    Const sIntervalloDati As String = "A2:E13"           '<<=== Modifica

    Set destWB = ThisWorkbook

    With destWB

        On Error Resume Next

        With Application

            .ScreenUpdating = False

            .DisplayAlerts = False

            .Sheets(sRiepilogo).ClearContents

            .DisplayAlerts = True

            Err.Clear

        End With

        On Error GoTo XIT

        With destWB

            Set destSH = .Sheets(1)

            Set destSH2 = .Sheets(2)

        End With

        With destSH.Range(sIntervalloDati)

            iRows = .Rows.Count

            iCols = .Columns.Count

        End With

    End With

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = oFSO.GetFolder(sPercorso)

    Set oFiles = oFolder.Files

    For Each oFile In oFiles

        With oFile

            sFilename = .Name

            If sFilename Like sNameType Then

                kCtr = kCtr + 1

                ReDim Preserve arrFilename(1 To kCtr)

                arrFilename(kCtr) = sFilename

                Set srcWb = Workbooks.Open(oFile)

                Set srcSH = srcWb.Sheets(1)

                Set srcRng = srcSH.Range(sIntervalloDati)

                With srcRng

                    jCtr = iCtr

                    iCtr = iCtr + iRows

                    If Not IsArrayAllocated(arrHeaders) Then

                        arrHeaders = .Rows(0).Value

                        ReDim Preserve arrHeaders(1 To 1, 1 To .Columns.Count + 1)

                        arrHeaders(1, .Columns.Count + 1) = "File Originale"

                    End If

                End With

                ReDim Preserve arrIn(1 To iCols + 1, 1 To iCtr)

                For i = 1 To iRows

                    For j = 1 To iCols

                        arrIn(j, jCtr + i) = srcRng.Cells(i, j).Value

                    Next j

                    arrIn(j, jCtr + i) = oFile.Name

                Next i

                srcWb.Close savechanges:=False

            End If

        End With

    Next oFile

    With destSH

        .Name = sRiepilogo

        Set destRng = destSH.Range("A2").Resize(iCtr, j)

        destRng.Value = Application.Transpose(arrIn)

        With destRng.Rows(0)

            .Value = arrHeaders

            .Font.Bold = True

        End With

        .UsedRange.EntireColumn.AutoFit

    End With

    With destSH2

        .Name = sElencoFile

        With .Range("A1")

            .Font.Bold = True

            .Value = sElencoFile

        End With

        .Range("A2").Resize(kCtr).Value = _

        Application.Transpose(arrFilename)

        .Columns(1).AutoFit

    End With

    Call MsgBox( _

         Prompt:="Finito" & vbNewLine _

                 & vbNewLine _

                 & "I dati dei seguenti file sono stati importati " _

                 & "sul foglio " & sRiepilogo & ":" _

                 & vbNewLine _

                 & Join(arrFilename, vbNewLine), _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Application.ScreenUpdating = True

End Sub

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

Public Function IsArrayAllocated(Arr As Variant) As Boolean

    On Error Resume Next

    IsArrayAllocated = IsArray(Arr) And _

                       Not IsError(LBound(Arr, 1)) And _

                       LBound(Arr, 1) <= UBound(Arr, 1)

End Function

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

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester
• Esegui

===

Regards,

Norman