Macro VBA copier format de cellule

Bonjour,

Dans le cadre de mon travail je dois faire un récapitulatif pour comparer la bonne concordance des données dans différents tableaux Excel (3 au total).

Dans mon classeur Excel accueillant ma Macro, je récupère les données de plusieurs fichiers Excel (Pouvant aller d'une dizaine à plus d'une centaine de classeurs).

Pour cela j'utilise le code ci-dessous.

Le soucis que j'ai, c'est que j'aimerais que les données copiées en U26 et en W26 soit copiée avec leur format d'origine. La Macro fonctionne pour ce qu'il s'agit de récupérer la valeur de la cellule cependant pour ces deux cellules, je veux leur valeur mais aussi la couleur de fond qui lui est associée.

Comment modifier le code pour que cela fonctionne ?

En vous remerciant d'avance.

P.S: Il faut savoir que je n'y connais rien VBA, cette formule est le fruit de mes recherches sur Internet.

'------------------------------------------------------------------------------
' Macro qui permet de compiler les informations contenues dans
' différents fichier pour les regrouper dans un fichier récapitulatif
' GCXL
'-------------------------------------------------------------------------------
Sub Creer_Recapitulatif()
Dim wbRecap As Workbook         'fichier recap
Dim wsRecap As Worksheet        'feuille où on écrit les données
Dim wbSource As Workbook        'fichier à ouvrir
Dim wsSource As Worksheet       'feuille où on cherche les données
Dim DernLign As Integer         'ligne où on écrit les données
Dim vFichiers As Variant        'noms des fichiers
Dim i As Integer, k As Integer
Dim rgRecap As Range            'plage où on copie les données

Set wbRecap = ThisWorkbook       'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets(1)  'on écrit dans la feuille 1 du fichier récapitulatif

' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir
    vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers

' --- Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
        Debug.Print "Aucun fichier sélectionné."
        MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."
Exit Sub
End If
On Error Resume Next

    Application.ScreenUpdating = False

' --- Boucle à travers les fichiers
For k = 1 To UBound(vFichiers)
        Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' C'est ici qu'on écrit les instructions
Set wbSource = Workbooks.Open(vFichiers(k))                        'on ouvre le fichier
Set wsSource = wbSource.Sheets(1)                                 'On copie les données de la feuille 1
        DernLign = wbRecap.Sheets(1).Range("A60000").End(xlUp).Row + 1     'ligne pour écrire le log des fichiers compilés

' - On copie les données vers le fichier Recapitulatif; à adapter
Set rgRecap = wsRecap.Range("A65000").End(xlUp).Offset(1, 0)
        rgRecap = Time
With wsSource
            rgRecap.Offset(0, 1) = .Range("A26")
            rgRecap.Offset(0, 2) = .Range("C26")
            rgRecap.Offset(0, 3) = .Range("M52")
            rgRecap.Offset(0, 4) = .Range("M53")
            rgRecap.Offset(0, 5) = .Range("U26")
            rgRecap.Offset(0, 6) = .Range("W26")
            rgRecap.Offset(0, 7) = .Range("A55")

End With

        wbSource.Close              'fermer fichier
Set wbSource = Nothing
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Next k

    Application.ScreenUpdating = True
    Application.StatusBar = False

End Sub

Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean

    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
    bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

Bonjour,

peut-être en modifiant la façon de copier les donnée :

  .Range("A26").copy rgRecap.Offset(0, 1)

au lieu de

rgRecap.Offset(0, 1) = .Range("A26")

A+

Super ! Sa fonctionne parfaitement et j'ai pu l'adapter aisément.

Je te remercie grandement.

J'en profite pour également demander si il est possible de récupérer le nom du dossier dans lequel est mon classeur Excel que je recopie.

Je compte remplacer le temps par cette information donc de remplacer ce bout de code :

En vous remerciant d'avance encore une fois

rgRecap = Time

à tester:

pour avoir le "chemin":

rgRecap = wbSource.Path

pour avoir le chemin et le nom du classeur

rgRecap = wbSource.FullName

A+

Je viens de tester tes deux solutions.

On s'y approche mais ce n'est pas tout à fait ça.

La première solution étant la plus proche car elle m'affiche le chemin jusqu'à mon dossier. Cependant je ne veux pas le chemin complet mais seulement le nom du dossier.

Au lieu d'avoir: C:\Users\(Nom d'utilisateur)\Desktop\(Nom du dossier)

J'aimerais n'avoir que le nom du dossier.

La deuxième solution, elle, rajoute le nom du fichier dans lequel je fais ma copie en plus de tout le reste.

EDIT:

Je viens de trouver ce que je cherchais en tâtonnant sur internet.

Pour ceux qui aimerais savoir, je le partage ici, ci-dessous:

rgRecap = Split(ActiveWorkbook.FullName, "\")(UBound(Split(ActiveWorkbook.FullName, "\")) - 1)

ce n'est pas le dossier que tu veux, mais le nom du classeur.

Alors

rgRecap = wbSource.Name

Bonne soirée

Rebonjour,

Je reviens car j'ai beau chercher, apprendre un peu le VBA etc... mais je n'arrive pas à travailler mon code assez bien pour réussir ce que je veux réaliser.

Ce que je veux faire c'est qu'une fois mes données récoltées, de plusieurs fichiers excel, par mon classeur Excel, je veux récupérer l'entièretés de ces données pour les coller dans un tableau de suivi.

Ayant plusieurs tableaux de suivis rangés par Départements.

L'idée de la macro serait de Sélectionner le fichier Excel à ouvrir (Là où l'on va coller les données) via une boîte de dialogue. Sélectionner les colonnes ("B:I") jusqu'aux dernières lignes ayant des cellules non vides (Comme quand on réalise CTRL+Bas).

Copier ces données et les coller (Simplement les valeurs), dans le tableau Excel que l'on a ouvert via la boîte de dialogue (Dans la Feuil2), à la suite d'autres données déjà rentrées dans ce tableau.

J'étais parti sur le même code cité plus haut comme base. (Je le remet à la suite de ce message).

Je suis conscient que ce que je demande ne doit pas être aisé à mettre en place et je m'en excuse par avance.

En vous remerciant d'avance !

'------------------------------------------------------------------------------
' Macro qui permet de compiler les informations contenues dans
' différents fichier pour les regrouper dans un fichier récapitulatif
' GCXL
'-------------------------------------------------------------------------------
Sub Recapitulatif()
Dim wbRecap As Workbook         'fichier recap
Dim wsRecap As Worksheet        'feuille où on écrit les données
Dim wbSource As Workbook        'fichier à ouvrir
Dim wsSource As Worksheet       'feuille où on cherche les données
Dim DernLign As Integer         'ligne où on écrit les données
Dim vFichiers As Variant        'noms des fichiers
Dim i As Integer, k As Integer
Dim rgRecap As Range            'plage où on copie les données

Set wbRecap = ThisWorkbook       'Fichier récapitulatif
Set wsRecap = wbRecap.Sheets(1)  'on écrit dans la feuille 1 du fichier récapitulatif

' --- Ouvrir boite de dialogue pour sélectionner les fichiers à ouvrir
    vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler") 'Appel de Fonction pour ouvrir fichiers

' --- Vérifier qu'au moins un fichier à été sélectionné
If Not IsArray(vFichiers) Then
        Debug.Print "Aucun fichier sélectionné."
        MsgBox "Erreur! Aucun/Mauvais fichier sélectionné."
Exit Sub
End If
On Error Resume Next

    Application.ScreenUpdating = False

' --- Boucle à travers les fichiers
For k = 1 To UBound(vFichiers)
        Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichiers)

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' C'est ici qu'on écrit les instructions
Set wbSource = Workbooks.Open(vFichiers(k))                        'on ouvre le fichier
Set wsSource = wbSource.Sheets(1)                                  'On copie les données de la feuille 1
        DernLign = wbRecap.Sheets(1).Range("A60000").End(xlUp).Row + 1     'ligne pour écrire le log des fichiers compilés

' - On copie les données vers le fichier Recapitulatif; à adapter
Set rgRecap = wsRecap.Range("B65000").End(xlUp).Offset(1, 0)
        rgRecap = Split(ActiveWorkbook.FullName, "\")(UBound(Split(ActiveWorkbook.FullName, "\")) - 1)
With wsSource
            rgRecap.Offset(0, 1) = .Range("A26")
            rgRecap.Offset(0, 2) = .Range("C26")
            rgRecap.Offset(0, 3) = .Range("M52")
            rgRecap.Offset(0, 4) = .Range("M53")
            .Range("U26").Copy rgRecap.Offset(0, 5)
            .Range("W26").Copy rgRecap.Offset(0, 6)
            rgRecap.Offset(0, 7) = .Range("A55")

End With

        wbSource.Close              'fermer fichier
Set wbSource = Nothing
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Next k

    Application.ScreenUpdating = True
    Application.StatusBar = False

End Sub

Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean

    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
    bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub