Unire file Excel

Frutto di un bel progetto in collaborazione con il dipartimento HR volto a cestinare un processo troppo manuale e altrettanto inefficiente.

La parte di sviluppo IT, con qualche modifica, è replicabile ad altre aree aziendali essendo riconducibile alla richiesta: “ho diversi file Excel che voglio copiare/incollare in un unico foglio”.

Nel caso specifico si trattava di raccogliere i file .xls “ferie e permessi goduti” provenienti da un numero variabile di utenti, sintetizzandoli in un unico foglio da importare successivamente nel portale che gestisce il payroll.

Sostanzialmente, per una prima fase del progetto, era necessario automatizzare questo flusso operativo:

  • Apro il file 01, copio le righe valorizzate.
  • Apro il file destinazione e incollo le righe appena copiate.
  • Chiudo il file 01 e apro il file 02.
  • Copio le righe valorizzate.
  • Incollo le righe appena copiate nel file destinazione sotto la prima riga libera.
  • Ripeto la stessa procedura per tutti i file da raccogliere (che possono variare per numero).
  • Salvo il file destinazione.

La macro che ho scritto è composta da 5 parti racchiuse in 3 moduli e da un form che si attiva mostrando all’utente una barra con percentuale di completamento (il “tocco di classe” finale). All’esecuzione, è sufficiente:

  • Selezionare la cartella in cui sono stati salvati tutti i file da unire.
  • Aspettare qualche secondo. La progress bar mostra la percentuale di completamento e, come ulteriore controllo, il numero totale dei file.
  • Salvare il file Excel ottenuto.

Ho reso disponibile il codice con licenza MIT, la descrizione dei blocchi è commentata nel codice stesso.

Il primo modulo è il cuore della macro e contiene, tra le altre cose, le chiamate agli altri moduli e alle subroutine.

Sub ConsolidaFerie()

Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim folder As String, choice As Integer

Application.ScreenUpdating = False 'disabilita l'aggiornamento dello schermo

Set mergeObj = CreateObject("Scripting.FileSystemObject")

'Scelta cartella in cui si trovano i file da consolidare
choice = Application.FileDialog(msoFileDialogFolderPicker).Show 'se l'utente ha selezionato una cartella, choice è <>0

'Se annullo il riquadro di selezione, devo uscire dalla routine
If choice = 0 Then
Exit Sub
End If

folder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
'folder = "cartella in cui sono salvati i file" in caso si decida di utilizzare una cartella fissa

ProgressBar.Show 'Apre il form ProgressBar

Set dirObj = mergeObj.Getfolder(folder)
Set filesObj = dirObj.Files

'Inizializza i contatori
Dim fileProc As Integer 'Serve a contare i file processati
fileProc = 0
Dim fileTot As Integer 'Serve a contare i file nella cartella (nr. totale)
fileTot = 0
Dim pctComp As Single 'Percentuale files processati
pctComp = 0

'Conta i file nella cartella temp
For Each everyObj In filesObj
fileTot = fileTot + 1
Next

For Each everyObj In filesObj
fileProc = fileProc + 1

pctComp = Round((fileProc * 100) / fileTot)

Call progress(pctComp, fileTot) 'Chiama l'aggiornamento della Progress Bar

Set bookList = Workbooks.Open(everyObj)

'La macro copia dai file nella cartella scelta 200 righe dalla cella A5 fino alla colonna Q
Range("A4:AF" & Range("A30").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate

'Posizione del cursore, parte dalla cella A65536 e sale fino al primo A vuoto che incontra
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close SaveChanges:=False
Next

'Routines per la pulizia del file (bordi, ordinamento)
Call PuliziaFile
Call OrdinaCognomi
Range("A1").Select

'Routine per la creazione del nuovo file e la chiusura del master
Call CreaFile

End Sub

Nello stesso modulo, ma come routine secondaria ho inserito l’animazione della progress bar.

Private Sub progress(pctComp As Single, fileTot As Integer)

ProgressBar.Text.Caption = "Elaborazione in corso: " & pctComp & "% " & " Totale file: " & fileTot
ProgressBar.Bar.Width = ((200 * pctComp) / 100) - 3     '-3 serve a non arrivare al bordo

DoEvents            'Aggiorna il form

End Sub

Il secondo modulo è destinato alla pulizia del file finale. È possibile che gli utenti, durante la compilazione, abbiano infatti personalizzato qualche formato cella.

Sub PuliziaFile()
' PuliziaFile Macro

'Toglie i bordi

Range("A4:AF60").Select
With Selection.Font
.Name = "Arial"
.Size = 10
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

'Converte i nomi in minuscolo (prima maiuscola)
Dim cell As Range
For Each cell In Range("A4:A60")
cell.Value = StrConv(cell.Value, 3)
Next

'   Range("A4").Select
End Sub

Ordinare per una data cella (Cognome utente, in questo caso specifico) migliora la leggibilità.

Sub OrdinaCognomi()
' OrdinaCognomi Macro

ActiveWorkbook.Worksheets("Calendario_Master").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Calendario_Master").Sort.SortFields.Add Key:=Range _
("A4:A60"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Calendario_Master").Sort
.SetRange Range("A3:AF60")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'   ActiveWindow.SmallScroll Down:=-6
'  Range("A4").Select
' ActiveWindow.SmallScroll Down:=-9
End Sub

Il terzo e ultimo modulo, contiene il codice per gli ultimi aggiustamenti sul file finale e la chiusura della macro stessa.

Sub CreaFile()
' CreaFile Macro

Range("A1:AF60").Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1:E1").Select
Columns("A:A").ColumnWidth = 14
Columns("B:AF").ColumnWidth = 6

Windows("Master.xlsm").Activate
Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False

End Sub

Licenza

Sub Licenza()

Term and Conditions:

Copyright (c) 2016 Andrea Gavazzi.

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the Software
is furnished to do so, subject to the following conditions:

The below copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.

End Sub

 

E questo è tutto, i file di esempio nella pagina OneDrive.