Создание сводной таблицы без пустых строк

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Создание сводной таблицы без пустых строк (Макросы/Sub)

joker007

Дата: Воскресенье, 06.12.2015, 19:27 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Доброго времени суток!
Помогите решить задачу чайнику.
На листе есть таблицы (штук 30) с размерами (длина*ширина) и количеством. Сверху каждой таблицы - кол-во таких изделий.
Нужно сформировать итоговую таблицу (на этом же листе) без пустых строк, с количеством деталей как в исходной, умноженной на кол-во изделий.
В файле примера внизу таблица, которую нужно получить.
Заранее спасибо всем, кто поможет.

К сообщению приложен файл: primer_06_12_15.xlsx (9.9 Kb)

Сообщение отредактировал joker007 - Воскресенье, 06.12.2015, 19:33

Ответить

nilem

Дата: Воскресенье, 06.12.2015, 19:53 | Сообщение № 2

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

joker007, привет
попробуйте вот так
[vba]

Код

Sub ertert()
Dim x, i&, j&, t(), s$
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 4 To Cells(5, Columns.Count).End(xlToLeft).Column Step 6
        x = Cells(5, i).CurrentRegion.Value
        For j = 3 To UBound(x)
            s = x(j, 1) & x(j, 2)
            If .Exists(s) Then
                t = .Item(s): t(2) = t(2) + x(j, 3)
                .Item(s) = t()
            Else
                .Item(s) = Array(x(j, 1), x(j, 2), x(j, 3))
            End If
        Next j
    Next i
    Range("D29").Resize(.Count, 3).Value = Application.Index(.Items, 0, 0)
End With
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

joker007

Дата: Воскресенье, 06.12.2015, 23:24 | Сообщение № 3

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

nilem, спасибо большое, работает!
Только, как сделать, чтобы значения в третьей колонке (количество) получалось из количества в исходной таблице, умноженной на кол-во изделий (жёлтая ячейка).

К сообщению приложен файл: 7929450.jpg (82.7 Kb)

Ответить

nilem

Дата: Понедельник, 07.12.2015, 07:51 | Сообщение № 4

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

добавил в 2-х строках со звездочками
[vba]

Код

Sub ertert()
Dim x, i&, j&, t(), s$
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 4 To Cells(5, Columns.Count).End(xlToLeft).Column Step 6
        x = Cells(5, i).CurrentRegion.Value
        For j = 3 To UBound(x)
            s = x(j, 1) & x(j, 2)
            If .Exists(s) Then
                t = .Item(s): t(2) = t(2) + x(j, 3) * x(1, 1) '***
                .Item(s) = t()
            Else
                .Item(s) = Array(x(j, 1), x(j, 2), x(j, 3) * x(1, 1)) '***
            End If
        Next j
    Next i
    Range("D29").Resize(.Count, 3).Value = Application.Index(.Items, 0, 0)
End With
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

joker007

Дата: Понедельник, 07.12.2015, 20:35 | Сообщение № 5

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

nilem, спасибо большое.
В примере работает как надо. Буду пытаться "прикрутить" к реальной таблице. Пока выдаёт ошибку "13" о несоответствии типов.

Ответить

Wasilich

Дата: Понедельник, 07.12.2015, 21:51 | Сообщение № 6

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация: 326 ±

Замечаний: 0% ±

2003

При неизменной расстановке таблиц можно так
[vba]

Код

Sub www()
   Dim k&, s&, t&, i&
    k = 4
    s = 30
    For t = 1 To 3
        For i = 7 To Cells(7, k).End(xlDown).Row
           Cells(s, 4) = Cells(i, k)
           Cells(s, 5) = Cells(i, k + 1)
           Cells(s, 6) = Cells(i, k + 2) * Cells(5, k)
           s = s + 1
        Next
      k = k + 5
    Next
End Sub

[/vba]

Сообщение отредактировал Wasilic - Понедельник, 07.12.2015, 21:53

Ответить

joker007

Дата: Понедельник, 07.12.2015, 23:18 | Сообщение № 7

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

К сожалению код nilem не хочет работать, когда вокруг таблиц есть ещё данные.
Wasilic, это почти то, что нужно. Как бы сделать так, чтобы макрос не останавливался, если какая-то таблица оказалась пустой, а проходил по всем.
Просто сформировать нужно три сводных таблицы: по голубым, салатовым и розовым полям. И не все из них будут заполнены.

К сообщению приложен файл: Primer_07_12_15.xlsm (87.8 Kb)

Ответить

nilem

Дата: Вторник, 08.12.2015, 08:46 | Сообщение № 8

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

а если так :)
[vba]

Код

Sub example_01()
Dim rng As Range, x, i&, j&
Dim aMDF As Object, aDVP As Object, aDSP As Object
Set rng = Range("D5:F29")
Set aMDF = CreateObject("System.Collections.ArrayList")
Set aDVP = CreateObject("System.Collections.ArrayList")
Set aDSP = CreateObject("System.Collections.ArrayList")

For j = 0 To 146 Step 5
    x = rng.Offset(, j).Value
    For i = 3 To 17
        If x(i, 3) > 0 Then aMDF.Add Array(x(i, 1), x(i, 2), x(i, 3) * x(1, 1))
    Next
    For i = 19 To 21
        If x(i, 3) > 0 Then aDVP.Add Array(x(i, 1), x(i, 2), x(i, 3) * x(1, 1))
    Next
    For i = 23 To 25
        If x(i, 3) > 0 Then aDSP.Add Array(x(i, 1), x(i, 2), x(i, 3) * x(1, 1))
    Next
Next j
Range("D90").Resize(, 11).CurrentRegion.ClearContents
With aMDF
    If .Count > 0 Then Range("D90").Resize(.Count, 3).Value = Application.Index(.ToArray, 0, 0)
End With
With aDVP
    If .Count > 0 Then Range("H90").Resize(.Count, 3).Value = Application.Index(.ToArray, 0, 0)
End With
With aDSP
    If .Count > 0 Then Range("L90").Resize(.Count, 3).Value = Application.Index(.ToArray, 0, 0)
End With
Set aMDF = Nothing: Set aDVP = Nothing: Set aDSP = Nothing
End Sub

[/vba]
или без объектов :(