Страницы: 1
RSS
Автоматическое заполнение общей таблицы, на основании добавления данных из других
 
Семен Селезнев, антиспам скрыл Ваше сообщение. Продубруйте его. И не нужно писать через 7-2-3 строки - зачем эти пустоты?
 
Понял. Повторюсь.
Есть 3 файла excel с однотипными таблицами. Каждую книгу редактирует ответственный менеджер (разделение по городам). Нужно сформировать единую таблицу, которая компилирует информацию с 3 таблиц. При этом все изменения сделанные менеджерами в своей таблице (гиперссылки, выделение цветом ячейки и тд), учитывались в общей таблице автоматически или полуавтоматически. Во вложении небольшой пример. В реальности все намного больше.
 
Код
Sub CollectSheets()
    Const f1 = "C:\tmp\1.xlsx"
    Const f2 = "C:\tmp\2.xlsx"
    Const f3 = "C:\tmp\3.xlsx"
    
    Dim y0 As Long
    Dim y1 As Long
    
    Dim wb0 As Workbook
    Set wb0 = Workbooks.Add(1)
    
    Dim wb1 As Workbook
    '--------------------------------------------------------
    On Error Resume Next
        Set wb1 = Workbooks.Open(f1, False, True)
    On Error GoTo 0
    If wb1 Is Nothing Then Exit Sub
    
    wb1.Sheets(1).Copy Before:=wb0.Sheets(1)
    wb1.Close False
    Set wb1 = Nothing
    '--------------------------------------------------------
    Application.DisplayAlerts = False
    wb0.Sheets(2).Delete
    Application.DisplayAlerts = True
    
    '--------------------------------------------------------
    On Error Resume Next
        Set wb1 = Workbooks.Open(f2, False, True)
    On Error GoTo 0
    If wb1 Is Nothing Then Exit Sub
        
    With wb0.Sheets(1)
        y0 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
        
    With wb1.Sheets(1)
        y1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Rows("2:" & y1).Copy wb0.Sheets(1).Cells(y0, 1)
    End With
        
    wb1.Close False
    Set wb1 = Nothing
    '--------------------------------------------------------
    On Error Resume Next
        Set wb1 = Workbooks.Open(f3, False, True)
    On Error GoTo 0
    If wb1 Is Nothing Then Exit Sub
        
    With wb0.Sheets(1)
        y0 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
        
    With wb1.Sheets(1)
        y1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Rows("2:" & y1).Copy wb0.Sheets(1).Cells(y0, 1)
    End With
        
    wb1.Close False
    Set wb1 = Nothing
    '--------------------------------------------------------
    
    wb0.Saved = True
End Sub
 
МатросНаЗебре, спасибо огромное! Попробовал. Работает. Единственное слетают гиперссылки и хотелось бы, чтобы подставления строк были по порядку. Для этого есть первый столбец с заявками. "1 заявка", "2 заявка", "3 заявка" и тд. Можно выстроить порядок именно по ним. Еще раз спасибо!
 
Код
Sub CollectSheets()
    Const f1 = "C:\tmp\1.xlsx"
    Const f2 = "C:\tmp\2.xlsx"
    Const f3 = "C:\tmp\3.xlsx"
    
    Dim y0 As Long
    Dim y1 As Long
    
    Dim wb0 As Workbook
    Set wb0 = Workbooks.Add(1)
    
    
    Dim wb1 As Workbook
    '--------------------------------------------------------
    On Error Resume Next
        Set wb1 = Workbooks.Open(f1, False, True)
    On Error GoTo 0
    If wb1 Is Nothing Then Exit Sub
    
    Dim s As String
    s = wb1.Path & "\Свод.xlsx"
    On Error Resume Next
        Workbooks("Свод.xlsx").Close False
        Kill s
    On Error GoTo 0
    wb0.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    
    wb1.Sheets(1).Copy Before:=wb0.Sheets(1)
    wb1.Close False
    Set wb1 = Nothing
    '--------------------------------------------------------
    Application.DisplayAlerts = False
    wb0.Sheets(2).Delete
    Application.DisplayAlerts = True
    
    '--------------------------------------------------------
    On Error Resume Next
        Set wb1 = Workbooks.Open(f2, False, True)
    On Error GoTo 0
    If wb1 Is Nothing Then Exit Sub
        
    With wb0.Sheets(1)
        y0 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
        
    With wb1.Sheets(1)
        y1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Rows("2:" & y1).Copy wb0.Sheets(1).Cells(y0, 1)
    End With
        
    wb1.Close False
    Set wb1 = Nothing
    '--------------------------------------------------------
    On Error Resume Next
        Set wb1 = Workbooks.Open(f3, False, True)
    On Error GoTo 0
    If wb1 Is Nothing Then Exit Sub
        
    With wb0.Sheets(1)
        y0 = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
        
    With wb1.Sheets(1)
        y1 = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Rows("2:" & y1).Copy wb0.Sheets(1).Cells(y0, 1)
    End With
        
    wb1.Close False
    Set wb1 = Nothing
    '--------------------------------------------------------
    SortSheet wb0.Sheets(1)
    
    wb0.Saved = True
End Sub


Sub SortSheet(sh As Worksheet)
    Dim y As Long
    Dim x As Integer
    With sh
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        
        Dim r As Range
        Set r = .Range(.Cells(1, 1), .Cells(y, x))
        Dim arr As Variant
        Dim brr As Variant
        
        arr = r
        For y = 1 To UBound(arr, 1)
            brr = Split(arr(y, 1), " ")
            brr(0) = Format(brr(0), "000000")
            arr(y, UBound(arr, 2)) = Join(brr, " ")
        Next
        r = arr
        
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Cells(1, x).Resize(y), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range(Cells(1, 1), Cells(y, x))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        r.Columns(x).Clear
    End With
End Sub
 
МатросНаЗебре, еще прошу прощения, за тупизм

Создаю 3 файлика, допустим 1, 2, 3.
Создаю еще 1 файлик, куда должно все подставляться, туда же вставляю, чуть измененный (адреса ссылок) код vba. И вместо того, чтобы все собиралось в этом файлике, мне создается еще один файл куда все собирается. Это получается где-то я туплю или при запуске всегда будет выдавать результат в новом файле?
 
В #5 при запуске всегда будет выдавать результат в новом файле.
 
МатросНаЗебре,  получается файлы всегда будут множиться при запускании макроса? Запускаю - создается ЛИСТ2, запускаю - создается ЛИСТ 3, запускаю создается ЛИСТ 4.
Нельзя сделать так, чтобы они записывались все в один файл и не множились?
 
Цитата
Семен Селезнев написал:
Запускаю - создается ЛИСТ2, запускаю - создается ЛИСТ 3, запускаю создается ЛИСТ 4.Нельзя сделать так, чтобы они записывались все в один файл и не множились?
Такое впечатление, что Вы какой-то другой макрос запускаете.
Должен создаваться файл "Свод" рядом с файлом f1.
У Вас создаются новые книги с названиями "ЛИСТ Х"?
 
Да создаются книги Лист X. Походу действительно что-то не то делаю. Если б еще уметь код читать, тогда б понимал принцип работы макроса. Буду пробовать дальше.
 
Покажите Ваш код.
 
МатросНаЗебре, Разобрался! работает. Спасибо огромное! Еще б сделать, так чтоб шапку не копировало или чтобы не копировало все что находится до 10 строки каждой книги.
 
Код
.Rows("2:"
Двойка тут означает, с какой строки копируются данные. Для файла 2 и более.
Если шапка не нужна и из первого файла, вставьте копирование аналогичное файлу 2.
 
МатросНаЗебре,Спасибо!

Уточните, еще пожалуйста, если в файле появится дополнительный лист или несколько листов и нужно будет с него также собирать информацию, то как это оформить кодом?
 
Единица здесь это индекс листа.
Код
With wb1.Sheets(1)
Если нужен второй лист, то надо использовать
Код
With wb1.Sheets(1)
Обратиться к листу можно и по имени
Код
With wb1.Sheets("Ведомость")
 
МатросНаЗебре,
Можете помочь добавить в макрос пример обращения к листу 2, в книге.
Чтобы он также добавлялся и фильтровался по 1 позиции.
Изменено: Семен Селезнев - 24.06.2021 15:35:51
 
Цитата
Семен Селезнев написал:
пример обращения к листу 2
Код
With wb1.Sheets(2)
Страницы: 1
Наверх