Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Объединение нескольких повторяющихся на одном листе таблиц
 
#1
13.11.2013 10:48:44
Всем доброго времени суток!
Столкнулся со следующей задачей (см. файл приложения):
на одном листе имеется большое количество таблиц с повторяющимися названиями
(Лист1 столбец А - название значений, столбец B - сами значения)
Необходимо объединить все эти таблицы в одну сводную, где в качестве названий столбцов будут
выступать названия значений, а ниже под ними сами значения (Лист 2).
 
 
 
#2
13.11.2013 11:44:51
запустите макрос - alt+F8 - prep - выполнить
Живи и дай жить..
 
 
 
#3
13.11.2013 12:06:06
Опоздал...
Ну чтоб не пропадало, и кому лень слэнов файл смотреть (мне лень  :)  ) :

Код
Option Explicit

Sub svod()
    Dim a(), i&, ii&, sklad As New Collection, vid As New Collection
    Dim t$, tt$, el

    On Error Resume Next
    a = Sheets(1).[a1].CurrentRegion.Value
    With CreateObject("Scripting.Dictionary"): .comparemode = 1
        For i = 1 To UBound(a)
            If Trim(a(i, 1)) = "USER LABEL" Then t = Trim(a(i, 2)): sklad.Add t, t
            If Left(Trim(a(i, 1)), 4) <> "----" Then
                tt = Trim(a(i, 1))
                vid.Add tt, tt
                .Item(t & "|" & tt) = Trim(a(i, 2))
            End If
        Next

        ReDim b(1 To sklad.Count + 1, 1 To vid.Count)

        i = 0
        For Each el In vid
            i = i + 1
            b(1, i) = el
        Next

        i = 1
        For Each el In sklad
            i = i + 1
            b(i, 1) = el
        Next

        For i = 2 To UBound(b)
            For ii = 2 To UBound(b, 2)
                b(i, ii) = .Item(b(i, 1) & "|" & b(1, ii))
            Next ii, i

        End With
        On Error GoTo 0

        With Sheets(2)
            .UsedRange.Clear
            .Cells(1).Resize(UBound(b), UBound(b, 2)) = b
        End With
    End Sub
Изменено: Hugo - 13.11.2013 12:06:28
 
 
 
#4
13.11.2013 12:07:34
Спасибо. Все получилось.
А стандартными способами (без макросов) эту задачу решить можно?
 
 
 
#5
13.11.2013 12:24:08
Можно формулой.
 
 
 
#6
13.11.2013 12:39:02
Цитата
(мне лень
для тех, кому лень
Код
Sub prep()
 Dim dic, ar, i&, p, n&
 Set dic = CreateObject("scripting.dictionary")
 ar = Sheets("Лист1").Cells(1).CurrentRegion
 ReDim p(1 To 1)
 n = 1
 For i = 1 To UBound(ar)
 If dic.exists(ar(i, 1)) Then
 p = dic(ar(i, 1))
 If UBound(p) = n Then n = n + 1
 ReDim Preserve p(1 To n)
 p(n) = ar(i, 2)
 dic(ar(i, 1)) = p
 Else
 p(n) = ar(i, 2)
 dic.Add ar(i, 1), p
 End If
 Next i
 ar = dic.keys
 With Sheets.Add
 .Cells(1).Resize(, UBound(ar) + 1) = ar
 For i = 0 To UBound(ar) - 1
 p = dic(ar(i))
 .Cells(2, i + 1).Resize(UBound(p) + 1) = Application.Transpose(p)
 Next i
 End With
End Sub
Живи и дай жить..
 
 
 
#7
13.11.2013 12:40:04
ой, а чей-то у меня вся табуляция слетела?
Живи и дай жить..
 
 
 
Страницы: 1
Наверх