Страницы: 1
RSS
Хитрое объединение таблиц
 
Есть три таблицы:

Таблица 1. Города
Город Транслит
Москва Mowscow
Тула Tula
Калуга Kaluga

Таблица 2. Транспорт
Тип транспорта
Трамвай
Троллейбус
Автобус
Маршрутка

Таблица 3. Цвет
Цвет Перевод
Красный Red
Зеленый green
Синий blue
Черный black
Бежевый yellow


Задача.
Сделать одну таблицу, в которой объединить все эти данные, по типу сочетания каждый с каждым.

В нашем примере - 3 строки в первой таблице, 4 во второй и 5 в третьей, значит строк должно быть: 60 (3*4*5)

Столбцов: 2 + 1 + 2
То есть для каждого города сделать перебор каждого транспорта с каждым цветом.
Столбцы будут такие:
Город, Транслит, Тип Транспорта, Цвет, перевод

Примеры строк
Москва Moscow Трамвай Красный Red
Москва Moscow Трамвай Зеленый green
Москва Moscow Трамвай Синий blue
...
Москва Moscow Троллейбус Красный Red
Москва Moscow Троллейбус Зеленый green
....и так далее.

Я сделал такое на циклах VBA, но работает это медленно. У меня в каждой таблице много записей и таблиц больше, поэтому финальный результат на примерно 130
тыс. строк получается.

Подскажите, куда копать?
 
Вы бы код написали, чтоб было понятно, где собака порылась...
Если автоматизировать бардак, то получится автоматизированный бардак.
 
Пример в аттаче.
Исходные таблицы и какой результат нужен.

Там все подписано. Нужно решение, которое сможет работать достаточно быстро (больше 100 тыс. строк в результате)
 
Цитата
volfram написал: Я сделал такое на циклах VBA...
а почему файл xlsx?
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
Ну вот сделал на циклах - все просто летает  :)
Код
Sub d()
Dim a(), b(), c(), full(), i&, ii&, iii&, t&
a = [a2:b4].Value
b = [d2:e5].Value
c = [g2:h6].Value
ReDim full(1 To UBound(a) * UBound(b) * UBound(c), 1 To 6)
For i = 1 To UBound(a)
    For ii = 1 To UBound(b)
        For iii = 1 To UBound(c)
        t = t + 1
            full(t, 1) = a(i, 1): full(t, 2) = a(i, 2)
            full(t, 3) = b(ii, 1): full(t, 4) = b(ii, 2)
            full(t, 5) = c(iii, 1): full(t, 6) = c(iii, 2)
        Next iii, ii, i
Sheets.Add
[a1:f1] = Array("Город", "Транслит", "Транспорт", "Транспорт, Eng", "Цвет", "Цвет, англ")
[a2].Resize(UBound(full), 6) = full
End Sub
 
SLAVICK, спасибо!
Все работает.

Теперь дополняю ваш код, что бы делать это с таблицами, которые постоянно меняют свой размер, дописываются строки, добавляются столбцы.

Сделал такой код:
Код
Sub d()
    
    Dim a(), b(), c(), ax()
    Dim full(), i&, ii&, iii&, t&
    
    'определяем ширину таблиц
    Dim x&, y&, z&
    x = Sheets("Источник").Cells.Find("*", [a1], xlFormulas, 1, 2, 2).Column
    y = Sheets("Источник 2").Cells.Find("*", [a1], xlFormulas, 1, 2, 2).Column
    z = Sheets("Источник 3").Cells.Find("*", [a1], xlFormulas, 1, 2, 2).Column
    
    'задаем массивы
    a = Sheets("Источник").[a3:c7].Value
    b = Sheets("Источник 2").[a3:a6].Value
    c = Sheets("Источник 3").[a3:b7].Value
    ax = Sheets("Источник").[a1:c1].Value
    
    
    ReDim full(1 To UBound(a) * UBound(b) * UBound(c), 1 To 10)
    For i = 1 To UBound(a)
        For ii = 1 To UBound(b)
            For iii = 1 To UBound(c)
            t = t + 1
                Count = 1
                'заполняем элементы массива
                For g = 1 To x
                    full(t, Count) = a(i, g)
                    Count = Count + 1
                Next g
                For g = 1 To y
                    full(t, Count) = b(ii, g)
                    Count = Count + 1
                Next g
                For g = 1 To z
                    full(t, Count) = c(iii, g)
                    Count = Count + 1
                Next g

            Next iii, ii, i
            
    Sheets.Add
    Sheets(1).Activate
    'Sheets(1).Range(Cells(1, 1), Cells(1, 3)) = ax()
    
    Sheets(1).[a3].Resize(UBound(full), x + y + z) = full
    Sheets(1).Cells(1, 1) = x
    Sheets(1).Cells(1, 2) = y
    Sheets(1).Cells(1, 3) = z
    
End Sub

Столкнулся с двумя проблемами.
1) Не могу понять, как задать гибко границы массива:
Код
Sheets("Источник").[a3:c7].Value 

Как подменять [a3:c7] на нужные мне переменные, например через Cells(3,1),Cells(7,1 + x)
2) Если разкомментировать эту строчку, начинает выдавать ошибку. Что не так?
Код
'Sheets(1).Range(Cells(1, 1), Cells(1, 3)) = ax
Изменено: volfram - 10.12.2015 15:08:39 (забыл загрузить файл)
 
Код
Sheets(1).Range(Cells(1, 1), Cells(1, 3)).Value = ax
Пробуйте.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Цитата
JayBhagavan написал:
Пробуйте.
Выдает странную ошибку - 400.
 
Sheets(1).Range(Cells(1, 1), Cells(1, 3)).Value
неправильно.
Надо
Код
Sheets(1).Range(Sheets(1).Cells(1, 1), Sheets(1).Cells(1, 3)).Value
или
Код
With Sheets(1)
.Range(.Cells(1, 1), .Cells(1, 3)).Value
End with

Подробнее: Как обратиться к диапазону из VBA
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
The_Prist, Вы правы. Часто упускаю этот момент из виду. Прошу прощения.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Цитата
volfram написал:
Как подменять [a3:c7] на нужные мне переменные,
Мне так нравится:
Код
With Sheets("Источник"): a = Range(.Cells(1, 1), .Cells(7, x)).Value: End With
Не заметил The_Prist практически так же написал :)
Изменено: SLAVICK - 10.12.2015 21:46:42
 
и зачем у Вас
Код
ReDim full(1 To UBound(a) * UBound(b) * UBound(c), 1 To 10)
если количество столбцов зависит от  x y z  - то лучше  сделать:
Код
ReDim full(1 To UBound(a) * UBound(b) * UBound(c), 1 To x + y + z)
 
В общем на сколько я понял нужно так:
Код
Sub d()
    Dim a(), b(), c(), ax(), ay(), az()
    Dim full(), i&, ii&, iii&, t&
    Dim x&, y&, z&
    
    'задаем массивы
    With Sheets("Источник")
        i = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Row
        x = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Column
        a = Range(.Cells(2, 1), .Cells(i, x)).Value
        ax = Range(.Cells(1, 1), .Cells(2, x)).Value
    End With
    With Sheets("Источник 2")
        i = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Row
        y = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Column
        b = Range(.Cells(2, 1), .Cells(i, x)).Value
        ay = Range(.Cells(1, 1), .Cells(2, y)).Value
    End With
    With Sheets("Источник 3")
        i = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Row
        z = .Cells.Find("*", .[a1], xlFormulas, 1, 2, 2).Column
        c = Range(.Cells(2, 1), .Cells(i, z)).Value
        az = Range(.Cells(1, 1), .Cells(2, z)).Value
    End With
    ReDim full(1 To UBound(a) * UBound(b) * UBound(c), 1 To x + y + z)
    For i = 1 To UBound(a)
        For ii = 1 To UBound(b)
            For iii = 1 To UBound(c)
            t = t + 1
                Count = 1
                'заполняем элементы массива
                For g = 1 To x: full(t, Count) = a(i, g): Count = Count + 1: Next g
                For g = 1 To y: full(t, Count) = b(ii, g): Count = Count + 1: Next g
                For g = 1 To z: full(t, Count) = c(iii, g): Count = Count + 1: Next g
            Next iii, ii, i
            
    Sheets.Add
    With Sheets(1)
        .Activate
        .Cells(1, 1).Resize(UBound(ax), UBound(ax, 2)) = ax
        .Cells(1, 1 + x).Resize(UBound(ay), UBound(ay, 2)) = ay
        .Cells(1, 1 + x + y).Resize(UBound(az), UBound(az, 2)) = az
        .Cells(2, 1).Resize(UBound(full), UBound(full, 2)) = full
    End With
End Sub
Изменено: SLAVICK - 10.12.2015 22:17:28
Страницы: 1
Читают тему (гостей: 1)
Наверх