Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Извлечение данных из разных ячеек в разных файлах и формирования нового файла
 
#1
14.11.2019 13:37:57
Добрый день!

Хотел узнать можно ли сделать макрос для извлечения данных из разных ячеек в разных файлах и формирования нового файла в котором все эти ячейки будут представлены в виде строчки

Примеры во вложении
Заранее благодарен!  
 
 
 
#2
14.11.2019 14:31:49
Код
Sub ВыводВстроку()
    Dim wb1 As Workbook:    Set wb1 = Workbooks("Пример файла.xlsx")
    Dim wb2 As Workbook:    Set wb2 = Workbooks("Пример свода.xlsx")
    
    Dim x As Long
    Dim i As Long
    Dim a As Variant
    Dim r As Range
    Dim c As Range
    Dim sh As Worksheet
    x = 1
    For Each sh In wb1.Worksheets
        On Error Resume Next
            Set r = Nothing
            Set r = sh.UsedRange.SpecialCells(xlCellTypeConstants)
        On Error GoTo 0
        If Not r Is Nothing Then
            ReDim a(1 To r.Cells.Count)
            i = 1
            For Each c In r
                a(i) = c.Value
                i = i + 1
            Next
            If x + UBound(a) > Columns.Count Then Exit For
            wb2.Sheets(1).Cells(1, x).Resize(1, UBound(a)) = a
            x = x + UBound(a)
            Erase a
        End If
    Next
End Sub
 
 
 
#3
14.11.2019 14:54:48
Спасибо!

Но, выдает такую ошибку, а как сделать так чтобы в формуле были прописаны номера ячеек и страница откуда нужно тянуть к примеру "Лист1!D9" и чтобы можно было вытаскивать из нескольких файлов одновременно
 
 
 
#4
14.11.2019 15:11:41
Код
Sub Пуговица()
    'Dim wb1 As Workbook:    Set wb1 = Workbooks("Пример файла.xlsx")
    'Dim wb2 As Workbook:    Set wb2 = Workbooks("Пример свода.xlsx")
    Dim wb2 As Workbook:    Set wb2 = Workbooks.Add
    
    Dim col As Collection
    Set col = New Collection
    col.Add Workbooks("Пример файла.xlsx").Sheets("Sheet1").Range("A1:Z100")
    col.Add Workbooks("Пример файла.xlsx").Sheets("Лист1").Range("A1:Z100")
     
    Dim x As Long
    Dim i As Long
    Dim a As Variant
    Dim r As Range
    Dim c As Range
    Dim v As Variant
    x = 1
    For Each v In col
        On Error Resume Next
            Set r = Nothing
            Set r = v.SpecialCells(xlCellTypeConstants)
        On Error GoTo 0
        If Not r Is Nothing Then
            ReDim a(1 To r.Cells.Count)
            i = 1
            For Each c In r
                a(i) = c.Value
                i = i + 1
            Next
            If x + UBound(a) > Columns.Count Then Exit For
            wb2.Sheets(1).Cells(1, x).Resize(1, UBound(a)) = a
            x = x + UBound(a)
            Erase a
        End If
    Next
End Sub
 
 
 
#5
14.11.2019 15:15:43
Ругается на строчку "col.Add Workbooks("C:\Users\dulat.anarbek\Downloads\Пример файла.xlsx").Sheets("Sheet1").Range("A1")"
 
 
 
#6
14.11.2019 15:28:02
Так работает с закрытыми книгами.
Код
Sub ИзЗакрытыхКниг()
    Dim wb1 As Workbook
    Dim wb2 As Workbook:    Set wb2 = Workbooks.Add
    
    Dim col As Collection
    Set col = New Collection
     
    col.Add Array("C:\tmp\Пример файла.xlsx", "Sheet1", "A1:Z100")
    col.Add Array("C:\tmp\Пример файла.xlsx", "Лист1", "A1:Z100")
     
    Dim x As Long
    Dim i As Long
    Dim a As Variant
    Dim r As Range
    Dim c As Range
    Dim v As Variant
    x = 1
    For Each v In col
        On Error Resume Next
            Set wb1 = Nothing
            Set wb1 = Workbooks.Open(v(LBound(v)), False, True)
            Set r = Nothing
            Set r = wb1.Sheets(v(LBound(v) + 1)).Range(v(LBound(v) + 2)).SpecialCells(xlCellTypeConstants)
        On Error GoTo 0
        If Not r Is Nothing Then
            ReDim a(1 To r.Cells.Count)
            i = 1
            For Each c In r
                a(i) = c.Value
                i = i + 1
            Next
            If x + UBound(a) > Columns.Count Then Exit For
            wb2.Sheets(1).Cells(1, x).Resize(1, UBound(a)) = a
            x = x + UBound(a)
            Erase a
        End If
        On Error Resume Next
            wb1.Close False
        On Error GoTo 0
    Next
End Sub
 
 
 
Страницы: 1
Наверх