VBA Переместить данные из книг в одну специальную книгу

Question

У меня есть файлы данных о продажах за каждый день за последние 5 лет (сотни книг).

В каждой книге есть много листов, и я ищу только информацию из сводного листа в каждом файле.

В каждом файле имеется сводная страница под названием «Сводная информация» с: 4 части данных в ячейках E12, E13, E14 и E15.

Я хочу взять эту информацию и перенести ее в строки в новом файле. Я также хочу, чтобы оно копировало название книги в колонку А и помещало данные рядом с ней (столбцы B-E).

Затем я хотел бы взять еще две части данных из другого рабочего листа в этих книгах и поместить их в столбцы справа от 4 выше (F, G).

Другой рабочий лист называется «Daily Detail». Поскольку количество продаж меняется каждый день, общее количество строк в каждом файле различно. Но две соответствующие строки помечены как «Total Pipes» и «Total Valves» (в столбце B), и данные расположены в столбце J для обеих строк.

У меня есть файлы, организованные в папках по годам, поэтому «2014». Можно ли запускать макрос для открытия файлов в папке без необходимости вручную открывать каждый файл?

Любые идеи о том, как создать макрос, чтобы захватить эти данные из каждой книги? Спасибо!

Answer 1

Голый минимум поиска на этом сайте принес бы вам что-то похожее на это. Проверьте содержание первенствует-УВУ документации (ее довольно полезный ресурс) >>

Sub Theloopofloops() 

Dim wbk As Workbook 
Dim Filename As String 
Dim path As String 
Dim rCell As Range 
Dim rRng As Range 
Dim wsO As Worksheet 
Dim StartTime As Double 
Dim SecondsElapsed As Double 
Dim sheet As Worksheet 

Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.Calculation = xlCalculationManual 

StartTime = Timer 

path = "pathtofile(s)" & "\" 
Filename = Dir(path & "*.xl??") 
Set wsO = ThisWorkbook.Sheets("Sheet1") 

Do While Len(Filename) > 0 
    DoEvents 
    Set wbk = Workbooks.Open(path & Filename, True, True) 
     For Each sheet In ActiveWorkbook.Worksheets 
       Set rRng = sheet.Range("b1:b308") 
       For Each rCell In rRng.Cells 
       If rCell <> "" And rCell.Value <> 0 Then 
        'code to do stuff 
        'avoid stuff like .copy/.paste 
        'using stuff like "sheet.range.value = sheet.range.value instead 
       End If 
       Next rCell 
     Next 
    wbk.Close False 
    Filename = Dir 
Loop 

Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.Calculation = xlCalculationAutomatic 

SecondsElapsed = Round(Timer - StartTime, 2) 
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation 

End Sub 

Также часть требований задавать вопросы на этом сайте, то, по крайней мере, пытались себя. Увидев, как этот код легко доступен уже во многих местах на этом сайте, я не видел вреда только в том, чтобы быть полезным :)

Также вам необходимо настроить этот код в соответствии с вашими потребностями. Я сделал тяжелую работу для вас.