Sub PaintReportTransfert()

MsgBox (" Vérifier que la feuille de classeur actif soit le fichier paint report transfer ")

' Suppression des datas déjà existante

Cells.Select
Selection.Delete Shift:=xlUp

' Creation du boutton de commencement

' Selection de la police et de la taille

Cells.Select
Selection.Font.Name = "Calibri"
Selection.Font.Size = 11

' Couleur En tête tableau

    Range("A1:G1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With

' Paint Report Type pour Paint Report Conca

Range("A1").Formula = "Block"

Range("B1").Formula = "Area No."

Range("C1").Formula = "Detail Area Name"

Range("D1").Formula = "Paint Code"

Range("E1").Formula = "Total Area (m^2)"

Range("F1").Formula = "Lot"

Range("G1").Formula = "Date of registration"

Range("A1:G1").Font.Bold = True

Range("A1:G1").Borders.Value = 1

' Alignement des écritures dans les cellules

With Range("A1:Z1000")
    .HorizontalAlignment = xlHAlignCenter 'ou xlHAlignLeft ou xlHAlignRight
    .VerticalAlignment = xlVAlignCenter 'ou xlVAlignTop ou xlVAlignBottom
End With

Dim BDD As FileDialog 'déclare la variable BDD (Boîte de Dialogue Dossier)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim FS As String 'décalre la variable FS (Fichier Source)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (celllue de DESTination)

'définit la boîte de dialogue BDD (permettant de définir le dossier des fichiers source)
Set BDD = Application.FileDialog(msoFileDialogFolderPicker)
With BDD 'prend en compte BDD
    .AllowMultiSelect = False 'n'autorise qu'une seule sélection
    .Show 'affiche BDD
    If .SelectedItems.Count = 0 Then Exit Sub 'si bouton [Annuler], sort de la procédure
    CA = .SelectedItems(1) & "\" 'définit la chemin d'accès CA aux fichiers à ouvrir
End With 'fin de la prise en compte de BDD

Set CD = ThisWorkbook 'définit la classeur destination CD
Set OD = CD.Sheets(1) 'définit l'onglet destination OD (à adapter à ton cas, ici j'ai mis le premier onglet)
FS = Dir(CA & "*.xlsm") 'définit le premier fichier source Excel contenu dans le dossier ayant CA comme chemin d'accès
Do While FS <> "" ' exécute tant qu'il existe des fichiers source
    Workbooks.Open CA & FS 'ouvre le fichier source FS
    Set CS = ActiveWorkbook 'définit la classeur source CS
    Set OS = CS.Worksheets(1) 'définit l'onglet source OS (à adapter à ton cas, ici j'ai j'ai mis le premier onglet)

'Selectionne les lignes 1 à 3

OS.Rows("1:3").Select

'Défusionne les cellules des lignes 1 à 3

OS.Rows("1:3").UnMerge

'Supprime les lignes 2 et 3

OS.Rows("1:3").Delete

'Supprimer les données de la plage I à AN

OS.Range("I:I,AN:AN,I:AN").ClearContents

'Supprime la colonne G

OS.Columns("G").Delete

'Supprime La colonne A et B
OS.Columns("A:B").Delete

' Recherche et Remplacement de data
OS.Cells.Replace What:="=""""", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Suppression de la dernière ligne du tableau

'OS.Cells(Rows.Count, 5).End(xlUp).EntireRow.Delete
OS.Range("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'Initialisation des variables

'Dim Cel As Range
'Dim Cel1 As Range

'For Each Cel1 In OS.Range("A1:E100")

'Set Cel = OS.Cells.Find(What:="Total")

' Boucle Si

'  If Not Cel Is Nothing Then

  ' Supprime La ligne ou le terme Total Apparait

'OS.Cells(Cel.Row, 1).EntireRow.Delete

 ' Message si la cellule n'est pas trouvé

 ' Else
  '  MsgBox " Fin des recherches de total "
   ' Exit For
  'End If

  'Next Cel1

'Insertion de la ligne 1

'OS.Rows("1:1").Insert

' Sauvegarde Automatique du Fichier

'ActiveWorkbook.Save

' Creation du tableau de la macro

'OS.Range("A1").Formula = "Block"

'OS.Range("B1").Formula = "Area No."

'OS.Range("C1").Formula = "Detail Area Name"

'OS.Range("D1").Formula = "Paint Code"

'OS.Range("E1").Formula = "Total Area (m^2)"

'OS.Range("F1").Formula = "Lot"

'OS.Range("G1").Formula = "Date of registration"

'OS.Range("A1:G1").Font.Bold = True

'OS.Range("A1:G1").Borders.Value = 1

' Selection de la police et de la taille

OS.Cells.Select
Selection.Font.Name = "Calibri"
Selection.Font.Size = 11

' Couleur En tête tableau

    'OS.Range("A1:G1").Select
    'With Selection.Interior
     '   .Pattern = xlSolid
      '  .PatternColorIndex = xlAutomatic
       ' .ThemeColor = xlThemeColorAccent1
        '.TintAndShade = 0.399975585192419
        '.PatternTintAndShade = 0
   ' End With

' Alignement des écritures dans les cellules

With OS.Range("A1:Z1000")
    .HorizontalAlignment = xlHAlignCenter 'ou xlHAlignLeft ou xlHAlignRight
    .VerticalAlignment = xlVAlignCenter 'ou xlVAlignTop ou xlVAlignBottom
End With

' Recupération du nom de fichier

Dim NomFichier As String
NomFichier = CS.Name

' Message du nom de Fichier

MsgBox NomFichier

' Déclaration des variables

Dim X As Long

' Boucle sur le nombre de ligne du paint report

For X = 1 To OS.Range("A" & OS.Rows.Count).End(xlUp).Row
'Range("A").End(xlDown).Row
'Range("A", Selection.End(xlDown)).Cells.Count
'Range("A" & Rows.Count).End(xlUp).Row
'Cells(Rows.Count, 1).End(xlUp).Row

' valeur de la colonne F sur la ligne X

' On inclut le nom du fichier dans la base de données Excel

  OS.Range("F" & X) = NomFichier

'Permet de récupérer seulement la partie du nom intéréssant

  OS.Range("F" & X) = Left(NomFichier, 3)

' Passage prochaine cellule

Next X

' Recupération de la date d'enregistrement

' Déclaration des variables

Dim MyDate As Date

'Initialisation de la date par rapport au fichier paint report conca

MyDate = FileDateTime("C:\Users\charl\OneDrive\Bureau\Code VBA CDA\Paint Report Transfer\Paint Report 113-114 Test.xlsm")    ' Returns "2/12/93 4:35:47 PM".

' Message de la date d'enregistrement

MsgBox MyDate

' Déclaration des variables

Dim Y As Long

' Boucle sur le nombre de ligne du paint report

For Y = 1 To OS.Range("A" & OS.Rows.Count).End(xlUp).Row

'  valeur sur le colonne G à la ligne X

'On inclut la date d'enregistrement dans la base de donnée excel

  OS.Range("G" & Y) = MyDate

' Passage prochaine cellule

Next Y

 ' Déclaration des variable

Dim Plage As Range, Cels As Range
Dim i As Integer, j As Integer

' Initialisation de i et j

i = 1
 j = 0

' Début de la boucle for pour chaque cellule du tableau définit

    For Each Cels In OS.Range("A1:A10") '

 ' Creation de la variable qui prend la valeur de la cellule

    A = Cels.Value

    'Boucle si qui vérifie que la cellule est vide et selectionne les cellules non vide
        If Cels.Value <> "" Then
            j = j + 1
            If j < 2 Then
                Set Plage = Cels
                Else
                Set Plage = Union(Plage, Cels)
            End If
        End If
    Next

'Déclaration de la plage selectionné
Plage.Select

' Boucle for pour chaque cellule de plage

For Each Cels In Plage

' Concaténation de la cellule

Cels.Formula = "'0" & Cels.Formula

' Passage à la nouvelle cellule

Next Cels

    '*******************************************************************************************
    ' cette partie correspond à ta macro du copier/coler. Adapte là à ton cas

    'définit la cellule de destination DEST (première cellule vide de la colonne A)
    Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0)
    OS.Range("A1:H50").Copy DEST 'copie la plage A1:H50 de l'onglet source et la colle dans DEST

    'sinon, tu supprimes cette partie et tu lances ta propre macro
    '*******************************************************************************************

    'call MaMacro

    CS.Close False 'ferme le classeur source CS (sans enregistrer)
    FS = Dir 'définit le prochain fichier source excel du dossier ayant CA comme chemin d'accès

Loop 'boucle