В этой статье мы создадим макрос для копирования ячеек во все книги в папке.

Мы использовали несколько примеров файлов Excel в качестве необработанных данных. Эти файлы содержат данные о посещаемости сотрудников. Каждый файл содержит дату, идентификатор сотрудника и имя сотрудников. Мы хотим добавить заголовки ко всем файлам в папке.

ArrowMain

ArrowFilesInFolder

ArrowRawData

При запуске макроса данные в диапазоне от H8 до J10 будут вставлены в качестве заголовка на все листы Excel в папке.

ArrowOutput

Объяснение кода

FolderPath = Sheet1.TextBox1.Value Приведенный выше код используется для присвоения значения в текстовом поле для упоминания переменной.

Dir (FolderPath & «* .xlsx»)

Приведенный выше код используется для получения имени первого файла в указанном пути к папке.

Хотя FileName <> «»

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

FileArray (Count1) = FileName FileName = Dir ()

Wend Приведенный выше код используется для создания массива строк. Он содержит имена всех файлов в папке.

Workbooks.Open (FolderPath & FileArray (i))

Приведенный выше код используется для открытия указанной книги.

SourceWB.Worksheets (1) .Range («H8: J10»). Скопируйте DestWB.Worksheets (1) .Range («A1: C3»)

Приведенный выше код используется для копирования заголовка из основной книги в другие книги.

Пожалуйста, введите код ниже

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

Если вам понравился этот блог, поделитесь им с друзьями на Facebook и Facebook.

Мы будем рады услышать от вас, дайте нам знать, как мы можем улучшить нашу работу и сделать ее лучше для вас. Напишите нам на [email protected]