Страницы: 1
RSS
Перенос данных из книг Excel
 
Добрый день!
Необходимо вывести данные  из определенных ячеек в одну. файлы все одинаковые.
подскажите как прописать что бы ячейки E14; G61; H61: i61; G76; H76: i76 с каждого из файлов затягивались в строки. важно что бы забирал из папки все файлы

Спасибо  
Изменено: oleg rud - 17.06.2021 11:04:38 (прикрепил файлы)
 
Предоставьте исходные файлы-примеры (что есть) и файл-результат (что должно получиться на выходе). Примеры и результат сделайте вручную согласно правил форума. Суммарный объём файлов не должен превышать 300кБ.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Прикрепил файлы  
 
Код
Option Explicit

Sub Main()
    Application.ScreenUpdating = False

    Dim arr As Variant
    arr = ShowFileDialog()
    Dim brr As Variant
    
    Dim orr As Variant
    ReDim orr(1 To UBound(arr, 1) + 1, 1 To 8)
    orr(1, 1) = "Файлы"
    orr(1, 2) = "ИНН"
    orr(1, 3) = "рейтинг 1"
    orr(1, 4) = "рейтинг 2"
    orr(1, 5) = "рейтинг 3"
    orr(1, 6) = "расчет 1"
    orr(1, 7) = "расчет 2"
    orr(1, 8) = "расчет 3"
    
    If Not IsEmpty(arr) Then
        Dim wb As Workbook
        Dim v As Variant
        Dim y As Long
        y = 1
        For Each v In arr
            Application.StatusBar = Right(v, 255)
            Set wb = Workbooks.Open(v, False, True)
            With wb.Sheets(1)
                brr = .Range(.Cells(1, 1), .Range("I76"))
            End With
            y = y + 1
            orr(y, 1) = wb.Name
            wb.Close
            
            orr(y, 2) = brr(7, 5) 'E7
            orr(y, 3) = brr(61, 7) 'G61
            orr(y, 4) = brr(61, 7) 'G61
            orr(y, 5) = brr(61, 9) 'I61
            orr(y, 6) = brr(76, 7) 'G76
            orr(y, 7) = brr(76, 7) 'G76
            orr(y, 8) = brr(76, 9) 'I76
            
            Application.StatusBar = False
        Next
        
        Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(orr, 1), UBound(orr, 2)) = orr
    End If
    
    Application.ScreenUpdating = True
End Sub

Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы отчетов" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
'        .Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
            'Workbooks.Open x 'открытие книги
            'можно также без х
            'Workbooks.Open .SelectedItems(lf)
        Next
        ShowFileDialog = arr
    End With
End Function
 
См. файл.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Спасибо большое, пол дня убил сегодня на это.
Подскажите есть файлы в формате xls их не тянет.  возможно как то сделать что бы читал оба формата xls и xlsx
 
oleg rud, у меня тянет. Приложите файл-пример, который "не тянет".

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
JayBhagavan, приветствую!
Изучал когда то на ваших решениях функцию Агрегат :D  
 
Нашел проблему, в некоторых файлах были скрытые листы, добавил что бы забирал с листа
Еще раз спасибо  
Изменено: oleg rud - 17.06.2021 14:34:22
Страницы: 1
Наверх