Dans cet article, nous allons créer une macro pour copier des cellules dans tous les classeurs d’un dossier.

Nous avons utilisé des exemples de fichiers Excel comme données brutes. Ces fichiers contiennent les détails de présence des employés. Chaque fichier contient la date, l’identifiant de l’employé et le nom des employés. Nous voulons ajouter des en-têtes à tous les fichiers du dossier.

ArrowMain

ArrowFilesInFolder

ArrowRawData

Lors de l’exécution de la macro, les données comprises entre H8 et J10 seront collées en tant qu’en-tête dans toutes les feuilles Excel du dossier.

ArrowOutput

Explication du code

FolderPath = Sheet1.TextBox1.Value Le code ci-dessus est utilisé pour attribuer une valeur dans la zone de texte pour mentionner la variable.

Dir (Chemin du dossier & « * .xlsx »)

Le code ci-dessus est utilisé pour obtenir le nom de fichier du premier fichier dans le chemin du dossier spécifié.

Alors que FileName <> «  »

Count1 = Count1 + 1 ReDim Preserve FileArray (1 To Count1)

FileArray (Count1) = FileName FileName = Dir ()

Wend Le code ci-dessus est utilisé pour créer un tableau de chaînes. Il contient les noms de tous les fichiers du dossier.

Workbooks.Open (FolderPath & FileArray (i))

Le code ci-dessus est utilisé pour ouvrir le classeur spécifié.

SourceWB.Worksheets (1) .Range (« H8: J10 »). Copier DestWB.Worksheets (1) .Range (« A1: C3 »)

Le code ci-dessus est utilisé pour copier l’en-tête du classeur principal vers d’autres classeurs.

Veuillez suivre ci-dessous pour le code

Option Explicit

Sub CopyingDataToFilesInFolder()

'Declaring variables

Dim FileName, FolderPath, FileArray() As String

Dim Count1, i As Integer

Dim SourceWB, DestWB As Workbook

'Getting folder path from the text box

FolderPath = Sheet1.TextBox1.Value

If Right(FolderPath, 1) <> "\" Then

FolderPath = FolderPath & "\"

End If

'Getting the file name from the folder

FileName = Dir(FolderPath & "*.xlsx")

Count1 = 0

'Creating an array which consists of file name of all files in the folder

While FileName <> ""

Count1 = Count1 + 1

ReDim Preserve FileArray(1 To Count1)

FileArray(Count1) = FileName

FileName = Dir()

Wend

Set SourceWB = ThisWorkbook

For i = 1 To UBound(FileArray)



'Opening the workbook

Set DestWB = Workbooks.Open(FolderPath & FileArray(i))



'Pasting the required header

SourceWB.Worksheets(1).Range("H8:J10").Copy DestWB.Worksheets(1).Range("A1:C3")



'Closing the workbook

DestWB.Close True

Next

Set DestWB = Nothing

Set SourceWB = Nothing

End Sub

Si vous avez aimé ce blog, partagez-le avec vos amis sur Facebook et Facebook.

Nous aimerions avoir de vos nouvelles, faites-nous savoir comment nous pouvons améliorer notre travail et le rendre meilleur pour vous. Écrivez-nous à [email protected]