Copier des cellules à tous les classeurs dans un dossier en utilisant VBA dans Microsoft Excel
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.
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.
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]