1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
| Option Explicit
Sub Consolidation_fichiers()
' Consolidation des fichiers sélectionnés
'
Dim f As Variant 'Tableau des noms complets des fichiers sélectionnés
Dim wbS As Workbook 'Classeur source
Dim wbC As Workbook 'Classeur cible
Dim shC As Worksheet 'Onglet cible
Dim msg As String 'Message d'erreur
Dim i As Long 'Index
' Choisir les classeurs sources
f = Application.GetOpenFilename(, , , , True)
If IsArray(f) Then
' Créer un nouveau classeur et définir l'onglet cible
With Workbooks.Add(xlWBATWorksheet)
Set shC = .Worksheets(1)
End With
shC.Name = "Consolidation"
' Compiler le premier onglet de chaque classeur
For i = LBound(f) To UBound(f)
On Error Resume Next
Set wbS = Workbooks.Open(f(i))
On Error GoTo 0
If Not wbS Is Nothing Then
If i = LBound(f) Then
' premier classeur
Call CompilerOnglet(wbS.Worksheets(1), shC, , True)
Else
' autres classeurs
Call CompilerOnglet(wbS.Worksheets(1), shC, 2, True)
End If
wbS.Close False
Else
msg = msg & vbCrLf & "- " & Mid(f(i), InStrRev(f(i), Application.PathSeparator) + 1)
End If
Next i
If msg > "" Then
MsgBox "Erreur à l'ouverture des fichiers suivants : " & msg & vbCrLf & vbCrLf & _
"Il n'ont pas été consolidés."
End If
End If
End Sub
Private Sub CompilerOnglet(wshSource As Worksheet, wshCible As Worksheet, _
Optional ligneDebutSource As Long = 1, Optional allFormat As Boolean = False)
' Ajoute les données sources dans la feuille cible
Dim src As Range
Dim dst As Range
Dim rng As Range
Dim drC As Long
Dim noC As Long
With wshCible
Set rng = .Cells.Find("*", , , , xlByRows, xlPrevious)
If rng Is Nothing Then
Set dst = .Range("A1")
Else
Set dst = .Range("A" & rng.Row).Offset(1)
End If
End With
With wshSource
Set rng = .Cells.Find("*", , , , xlByRows, xlPrevious)
If Not rng Is Nothing Then
Set src = .Range(.Rows(ligneDebutSource), .Rows(rng.Row))
If allFormat Then
Application.ScreenUpdating = False
src.Copy Destination:=dst
drC = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
For noC = 1 To drC
wshCible.Columns(noC).ColumnWidth = wshSource.Columns(noC).ColumnWidth
Next noC
Application.ScreenUpdating = True
End If
dst.Resize(src.Rows.Count, src.Columns.Count).Value = src.Value
End If
End With
End Sub |
Partager