Option Explicit
Sub Fusion2()
'*******************************************************
'Declaration des variables
Dim repertoire_source As String 'Nom repertoire contenant les fichiers a concaténé (sources)
Dim repertoire_det As String 'Nom repertoire contenant les fichiers concaténés (resultats)
Dim objFSO, objDossier, objFichier
Dim mesfichiers() As String
Dim fichier_ss_extension As String 'Nom du fichier sans la lettre afin de le mettre en haut de la colonne A dans le fichier resultat
Dim old_fichier_ss_extension As String
Dim i, b As Double 'Compteur utilisé dans différentes parties du code
Dim valeurs() As String 'On va copier la colonne B dans ce tableau
Dim workbook_in As Workbook 'Classeur Excel en entrée
Dim workbook_Fusion As Workbook 'Classeur Excel en sortie : Fusion
Dim compteur_valeur As Double 'compteur du nombre de valeurs stocké dans le tableau Valeurs()
'*******************************************************
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'******************************************
'Définition des valeurs constantes A MODIFIER
repertoire_source = "C:\" 'NE PAS OUBLIER LE \ A LA FIN DU CHEMIN
repertoire_det = "C:\" 'NE PAS OUBLIER LE \ A LA FIN DU CHEMIN
Application.DisplayAlerts = True 'False = Pas de message si fichier existe deja = Il sera ecrasé
'True = Message de confirmation d'ecrasement de fichier si deja existant
'******************************************
'*********************************************************
'On va parcourir les fichiers de types excel dans le repertoire source et on va stocker leur nom
'dans le tableau mesfichiers()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDossier = objFSO.GetFolder(repertoire_source) 'On ouvre le repertoire source
'On peuple les noms de fichier dans le tableau mesfichiers()
i = 0 'Init de i=0
If (objDossier.Files.Count > 0) Then 'Si il y a des fichiers
For Each objFichier In objDossier.Files
If (InStr(1, objFichier.Name, ".xls", 1) > 0) Then 'Si il y a des fichiers de type Excel
ReDim Preserve mesfichiers(i)
mesfichiers(i) = objFichier.Name
i = i + 1
End If
Next
End If
'************************************************************
'************************************************************
'Lancement du traitement
compteur_valeur = 0
For i = 0 To UBound(mesfichiers) 'Pour tous les fichiers a traiter
'On enleve extension + lettre au nom de fichier afin de le comparer
fichier_ss_extension = Mid(mesfichiers(i), 1, InStr(1, mesfichiers(i), ".") - 2) 'Ici on n'a que le numero de ref sans la lettre afin de la comparer a l'autre fichiers
If fichier_ss_extension = old_fichier_ss_extension Then 'Si même famille de fichier => On stoque dans le tableau valeurs()
'ouverture du fichier Excel
Set workbook_in = Workbooks.Open(repertoire_source & mesfichiers(i), , ReadOnly:=True) 'Ouverture en Readonly
'On stock dans le tableau
b = 2
While workbook_in.ActiveSheet.Cells(b, 2) <> "" 'On parcours depuis la ligne 2
ReDim Preserve valeurs(2, compteur_valeur) 'Ajoute un espace memoire au tableau
valeurs(1, compteur_valeur) = workbook_in.ActiveSheet.Cells(b, 2)
valeurs(2, compteur_valeur) = i
compteur_valeur = compteur_valeur + 1
b = b + 1
Wend
workbook_in.Close
Else 'Si pas même famille alors on ferme le fichier fusionné precedemment on on stocke le prochain
'On ouvre le nouveau fichier fusionné avec le nom ancien....et on sauveagde les données
If i > 0 Then 'Si pas premier passage
Set workbook_Fusion = Workbooks.Add
workbook_Fusion.ActiveSheet.Cells(1, 1) = old_fichier_ss_extension 'On copie le nom du fichier dans le cellule A1
For b = 0 To UBound(valeurs, 1) 'pour toutes les valeurs stoquées dans le tableau
Cells(b + 2, 2) = valeurs(1, b)
Cells(b + 2, 2).Interior.ColorIndex = 2 + valeurs(2, b)
Next
On Error Resume Next
workbook_Fusion.SaveAs repertoire_det & old_fichier_ss_extension & "_Fusion.xls"
workbook_Fusion.Close
'On reinitialise le tableau et le compteur
ReDim valeurs(0, 0)
compteur_valeur = 0
End If
'ouverture du fichier Excel
Set workbook_in = Workbooks.Open(repertoire_source & mesfichiers(i), , ReadOnly:=True) 'Ouverture en Readonly
'On stock dans le tableau
b = 2
While workbook_in.ActiveSheet.Cells(b, 2) <> "" 'On parcours depuis la ligne 2
ReDim Preserve valeurs(2, compteur_valeur) 'Ajoute un espace memoire au tableau
valeurs(1, compteur_valeur) = workbook_in.ActiveSheet.Cells(b, 2)
valeurs(2, compteur_valeur) = i
compteur_valeur = compteur_valeur + 1
b = b + 1
Wend
workbook_in.Close
End If
old_fichier_ss_extension = fichier_ss_extension
Next
'On finit le dernier Fichier
'On ouvre le nouveau fichier fusionné avec le nom ancien....et on sauveagde les données
Set workbook_Fusion = Workbooks.Add
workbook_Fusion.ActiveSheet.Cells(1, 1) = old_fichier_ss_extension 'On copie le nom du fichier dans le cellule A1
For b = 0 To UBound(valeurs, 2) 'pour toutes les valeurs stoquées dans le tableau
Cells(b + 2, 2) = valeurs(1, b)
Cells(b + 2, 2).Interior.ColorIndex = 2 + valeurs(2, b)
Next
workbook_Fusion.Activate
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
With workbook_Fusion.Worksheets("Feuil1").Sort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
workbook_Fusion.SaveAs repertoire_det & old_fichier_ss_extension & "_Fusion.xls"
workbook_Fusion.Close
End Sub
