Не, ещё не всё. Мой код сейчас подтягивает данные во вторую таблицу по уже занесённым туда названиям, а нужно сделать чтоб как PQ делает - названия берутся из источника. Вот, теперь вторая таблица генерится в коде. Правда без рамки, но если нужно - можно добавить. [vba]
Код
Option Explicit
Sub tt() Dim a, el, i&, t$, col As New Collection
a = ActiveSheet.UsedRange.Columns(1).Resize(, 3).Value
With CreateObject("Scripting.Dictionary") For Each el In Array(510101, 510102, 510103) .Item(el) = 0& Next For i = 2 To UBound(a) If Len(a(i, 2)) = 0 Then If Len(a(i, 1)) Then t = a(i, 1): col.Add t End If If .exists(a(i, 1)) Then .Item(t & "d") = a(i, 2) .Item(t & "c") = a(i, 3) End If Next
ReDim a(1 To col.Count + 1, 1 To 3) a(1, 2) = [b1] a(1, 3) = [c1] For i = 2 To UBound(a) a(i, 1) = col(i - 1) a(i, 2) = .Item(a(i, 1) & "d") a(i, 3) = .Item(a(i, 1) & "c") Next [i3].Resize(UBound(a), 3).Value = a End With End Sub
[/vba]
Не, ещё не всё. Мой код сейчас подтягивает данные во вторую таблицу по уже занесённым туда названиям, а нужно сделать чтоб как PQ делает - названия берутся из источника. Вот, теперь вторая таблица генерится в коде. Правда без рамки, но если нужно - можно добавить. [vba]
Код
Option Explicit
Sub tt() Dim a, el, i&, t$, col As New Collection
a = ActiveSheet.UsedRange.Columns(1).Resize(, 3).Value
With CreateObject("Scripting.Dictionary") For Each el In Array(510101, 510102, 510103) .Item(el) = 0& Next For i = 2 To UBound(a) If Len(a(i, 2)) = 0 Then If Len(a(i, 1)) Then t = a(i, 1): col.Add t End If If .exists(a(i, 1)) Then .Item(t & "d") = a(i, 2) .Item(t & "c") = a(i, 3) End If Next
ReDim a(1 To col.Count + 1, 1 To 3) a(1, 2) = [b1] a(1, 3) = [c1] For i = 2 To UBound(a) a(i, 1) = col(i - 1) a(i, 2) = .Item(a(i, 1) & "d") a(i, 3) = .Item(a(i, 1) & "c") Next [i3].Resize(UBound(a), 3).Value = a End With End Sub