Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Размножить таблицу на строки другой таблицы
 
#1
11.11.2019 13:49:13
Добрый день!

Имеются две таблицы: первая со списком поставщиков, вторая со списком товаров. Каждый поставщик из первой таблицы осуществляет поставки товаров из второй таблицы. Необходимо свести таблицы так, чтобы итоговая таблица содержала распределение поставляемых товаров по поставщикам. Т.е. необходимо произвести копирование списка товаров вниз по строкам столько раз сколько содрежиться поставщиков в списке первой таблицы и напротив каждой вновь скопированной таблицы проставить поставщика.

Буду благодарен за готовый макрос.
Изменено: neqkeet - 11.11.2019 13:50:44
 
 
 
#2
11.11.2019 14:27:54
Код
Sub РазмножениеПоставщикованием()
    Dim rP As Range
    Dim rT As Range
    Dim y As Long
    
    y = Cells(Rows.Count, 1).End(xlUp).Row
    Set rP = Range(Cells(2, 1), Cells(y, 2))    y = Cells(Rows.Count, "E").End(xlUp).Row
    Set rT = Range(Cells(2, "E"), Cells(y, "H"))    rP.Rows(1).Copy Range("K2")
    rT.Rows(1).Copy Range("M2")
    
    Dim p As Long
    p = 2
    
    Do
        If p > rP.Rows.Count Then Exit Do
        y = Cells(Rows.Count, "K").End(xlUp).Row + 1
        rP.Rows(p).Copy Cells(y, "K").Resize(rT.Rows.Count - 1)
        rT.Offset(1).Copy Cells(y, "M")
        p = p + 1
    Loop
End Sub
 
 
 
#3
11.11.2019 14:42:39
neqkeet, вариант
Код
Sub csg()
Dim iCell As Range, mCell As Range, FreeRow As Long, lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 11).End(xlUp).Row
If lr < 3 Then lr = 3
Range("K3:P" & lr).ClearContents
FreeRow = 3
    For Each iCell In Range(Cells(3, "A"), Cells(Rows.Count, "A").End(xlUp))
        For Each mCell In Range(Cells(3, "E"), Cells(Rows.Count, "E").End(xlUp))
            If iCell <> "" Then
                Range(Cells(iCell.Row, 1), Cells(iCell.Row, 2)).Copy Cells(FreeRow, 11)
                Range(Cells(mCell.Row, 5), Cells(mCell.Row, 8).Copy Cells(FreeRow, 13)
                FreeRow = FreeRow + 1
            End If
        Next
    Next
Application.ScreenUpdating = True
End Sub
 
 
 
#4
11.11.2019 15:03:21
Добрый день!
вариант на PQ
 
 
 
#5
13.11.2019 10:13:23
Всем огромное спасибо!

casag, МатросНаЗебре, можно ли сделать более универсальный макрос, с возможностью выбора диапазонов каждой из таблиц и помещения результатов слияния на новый лист? Количество столбцов и строк как в первой таблице так и во второй может варьироваться.

Stics, в PQ никогда не работал, буду признателен если подскажите каким образом сделать такое слияние/поделитесь ссылкой на материал.  
 
 
 
#6
13.11.2019 11:08:34
Вариант на MS Query (поэтому будет работать и в старых версиях excel)
Файл должен быть сохранен, как указано в яч. A11

PS
MS Query - это прадедушка PQ :)
Изменено: Михаил Лебедев - 13.11.2019 11:11:17
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
 
 
#7
13.11.2019 23:09:16
neqkeet, универсальный макрос. Таблицы могут находится на любых листах, в любом месте. Результат также выводится на любой лист. Диапазон таблицы указывать без шапки (неизвестно сколько строк  может занимать  шапка). Макрос можно запускать с любого листа.
Код
Sub csg()
Dim myRange1 As Range, myRange2 As Range, myRange3 As Range
 Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Dim iCell As Range, mCell As Range
Dim i1&, i2&, c1&, c2&, j1&, j2&, n1&, n2&, k1&, k2&
On Error GoTo Inform
 Set myRange1 = Application.InputBox("Укажите первый диапазон:", "Выбор", Type:=8)
 Set Ws1 = myRange1.Worksheet
  i1 = myRange1.Row:  i2 = myRange1(myRange1.Count).Row
  c1 = myRange1.Column: c2 = myRange1(myRange1.Count).Column
 Set myRange2 = Application.InputBox("Укажите второй диапазон:", "Выбор", Type:=8)
 Set Ws2 = myRange2.Worksheet
  j1 = myRange2.Row:  j2 = myRange2(myRange2.Count).Row
  n1 = myRange2.Column:  n2 = myRange2(myRange2.Count).Column
 Set myRange3 = Application.InputBox("Укажите ячейку для вставки:", "Выбор", Type:=8)
 Set Ws3 = myRange3.Worksheet
  k1 = myRange3.Row:  k2 = myRange3.Column
 For Each iCell In Ws1.Range(Ws1.Cells(i1, c1), Ws1.Cells(i2, c1))
        For Each mCell In Ws2.Range(Ws2.Cells(j1, n1), Ws2.Cells(j2, n1))
            If iCell <> "" Then
                Ws1.Range(Ws1.Cells(iCell.Row, c1), Ws1.Cells(iCell.Row, c2)).Copy Ws3.Cells(k1, k2)
                Ws2.Range(Ws2.Cells(mCell.Row, n1), Ws2.Cells(mCell.Row, n2)).Copy Ws3.Cells(k1, k2).Offset(0, c2 - c1 + 1)
                k1 = k1 + 1
            End If
        Next
    Next
    Ws3.Activate
    Exit Sub
Inform:
MsgBox "Диалог закрыт или нажата кнопка " _
& Chr(34) & "Отмена" & Chr(34) & "!"
Exit Sub
End Sub
 
 
 
#8
14.11.2019 00:35:17
в PQ
Код
= Table.Join(Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content], {}, Excel.CurrentWorkbook(){[Name="Таблица2"]}[Content], {})
 
 
 
Страницы: 1
Наверх