VBA Проход по файлам в папке и копирование / вставка диапазона переменных в мастер-файл - PullRequest
Новая
       8

VBA Проход по файлам в папке и копирование / вставка диапазона переменных в мастер-файл

0 голосов
/ 18 января 2019

Я некоторое время искал, пытаясь найти решение, я могу найти похожие решения, но не могу заставить работать даже с твиками и поправками.

У меня есть главная рабочая книга под названием «Master.xlsb» с 1 листом «Сводка». У меня есть список из 189 файлов в одной папке под названием «EmailAttachments».

Каждый отдельный файл будет иметь различное количество строк, поэтому я хотел бы просмотреть все файлы и скопировать их из диапазона «B7: B» и LastRow »и вставить данные ниже последней строки, содержащей данные в« Master.xlsb »( Который будет увеличиваться по мере вставки данных).

Кроме того, я хотел бы, чтобы имя файла в столбце A начиналось с «A7», поэтому я знаю, из какого файла получены данные.

Заранее спасибо.

EDIT:

Мне удалось заставить код работать ниже: 

Public Sub DataToSummary()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRowMaster As Long
Dim DataRowsMaster As Long
Dim LastRowSource As Long
Dim FileNameSource As String
Dim i As Integer, intValueToFind As Integer

Path = "C:\Example\Path\"
Filename = Dir(Path & "*.xlsx")

 Do While Len(Filename) > 0
    Set wbk = Workbooks.Open(Path & Filename)
                For i = 1 To 500
                If Cells(i, 1).Value = intValueToFind Then
                    GoTo Skip
                End If
                Next i
            LastRowSource = Cells(Rows.Count, 2).End(xlUp).Row
            DataRowsSource = LastRowSource - 6
            FileNameSource = Left(Filename, Len(Filename) - 5)
            Workbooks(Filename).Sheets(1).Range("B7:M" & LastRowSource).Copy

            Workbooks("Master.xlsb").Activate
            LastRowMaster = Cells(Rows.Count, 6).End(xlUp).Row
            ThisWorkbook.Sheets(1).Range("F" & LastRowMaster + 1).PasteSpecial xlPasteValues
            ThisWorkbook.Sheets(1).Range("B" & LastRowMaster + 1 & ":B" & LastRowMaster + DataRowsSource).Value = FileNameSource
            ThisWorkbook.Sheets(1).Range("C1:E1").Copy
            ThisWorkbook.Sheets(1).Range("C" & LastRowMaster + 1 & ":E" & LastRowMaster + DataRowsSource).PasteSpecial xlPasteFormulas
Skip:
    wbk.Close True
    Filename = Dir
Loop
End Sub

Ответы [ 2 ]

0 голосов
/ 01 февраля 2019

Ниже код работал для меня (Изменить пример пути): 

Public Sub DataToSummary()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim LastRowMaster As Long
Dim DataRowsMaster As Long
Dim LastRowSource As Long
Dim FileNameSource As String
Dim i As Integer, intValueToFind As Integer

Path = "C:\Example\Path\"
Filename = Dir(Path & "*.xlsx")

 Do While Len(Filename) > 0
    Set wbk = Workbooks.Open(Path & Filename)
                For i = 1 To 500
                If Cells(i, 1).Value = intValueToFind Then
                    GoTo Skip
                End If
                Next i
            LastRowSource = Cells(Rows.Count, 2).End(xlUp).Row
            DataRowsSource = LastRowSource - 6
            FileNameSource = Left(Filename, Len(Filename) - 5)
            Workbooks(Filename).Sheets(1).Range("B7:M" & LastRowSource).Copy

            Workbooks("Master.xlsb").Activate
            LastRowMaster = Cells(Rows.Count, 6).End(xlUp).Row
            ThisWorkbook.Sheets(1).Range("F" & LastRowMaster + 1).PasteSpecial xlPasteValues
            ThisWorkbook.Sheets(1).Range("B" & LastRowMaster + 1 & ":B" & LastRowMaster + DataRowsSource).Value = FileNameSource
            ThisWorkbook.Sheets(1).Range("C1:E1").Copy
            ThisWorkbook.Sheets(1).Range("C" & LastRowMaster + 1 & ":E" & LastRowMaster + DataRowsSource).PasteSpecial xlPasteFormulas
Skip:
    wbk.Close True
    Filename = Dir
Loop
End Sub
0 голосов
/ 18 января 2019

Здесь я нашел хороший код от пользователя benmichae2. для просмотра файлов в папке Прокручивать файлы в папке с помощью VBA?

Повторно используя его / ее код, я бы сделал что-то вроде этого:

Параметр Явный 

Sub LoopThroughFiles()

Dim firstEmptyRow As Long
Dim attachmentFolder As String, StrFile As String, filenameCriteria As String
Dim attachmentWorkBook As Workbook
Dim copyRngToArray As Variant

'# Define folder with attachments and set file extension
attachmentFolder = "C:\temp"
filenameCriteria = "xlsx"

'set
StrFile = Dir(attachmentFolder & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
    Set attachmentWorkBook = Workbooks.Open(StrFile)

    With attachmentWorkBook.Worksheets(1)
        '#Copy the first column to array starting from "A7" to End of column
         copyRngToArray = .Range("A7:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With

    '#Thisworkbook is the file where this code is in actually your Master.xlsb file
    With ThisWorkbook.Worksheets(1)
        '#firsEmptyRow returns the first empty row in column B
        firstEmptyRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
        '#paste file name to Column A
        .Range("A" & firstEmptyRow) = StrFile
        '#paste data in column B
        .Range("B" & firstEmptyRow).Resize(UBound(copyRngToArray)) = copyRngToArray
    End With

    Set attachmentWorkBook = Nothing
    StrFile = Dir
Loop

End Sub

Вставьте этот код в модуль и сверьтесь с некоторыми примерами файлов Excel

...