Поиск нужного значения, фильтрация и суммирование

@CrazyTonik · Регистрация: 10.07.2014

Студворк — интернет-сервис помощи студентам

Прикладываю пример.
Нужно чтобы в таблице "Калькуляция" столбец "Кол-во" заполнялся автоматически по ходу добавления данных. Например, добавили новую сводку - и в таблице "Калькуляция" добавился вес определенного материала. В идеале, конечно, чтобы и сам материал добавлялся, если его еще нет в списке. Ну это уже, похоже, слишком сложно.
Обычно количество сводок в одном документе достигает до 100 штук.
Очень нужен макрос.

@KoGG · 11.07.2014, 12:13

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub Собрать_калькуляцию()
    Dim a(), i&, k%, Kolvo#, EdIzm$, Ed, vX
    Set Ed = CreateObject("Scripting.Dictionary")
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        With Sheets("Сводки")
            a = Intersect(.UsedRange, .Columns("C:E")).Value
        End With
        For i = 1 To UBound(a)
            a(i, 1) = Trim(a(i, 1))
            Select Case UCase(a(i, 1))
                Case "МАТЕРИАЛ", "ПРИНЯЛ", "ФИО", ""
                Case Else
                    a(i, 3) = Trim(a(i, 3))
                    Kolvo = Val(Replace((a(i, 3)), ",", "."))
                    k = InStr(1, a(i, 3), " ")
                    EdIzm = IIf(k > 0, Trim(Right(a(i, 3), Len(a(i, 3)) - k)), "")
                    .Item(a(i, 1)) = .Item(a(i, 1)) + Kolvo
                    Ed.Item(a(i, 1)) = EdIzm
            End Select
        Next i
        k = .Count + 2
        With Sheets("Калькуляция")
            Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 4)).Clear
            Range(.Cells(3, 1), .Cells(k, 4)).Borders.LineStyle = xlContinuous
        End With
        i = 3
        For Each vX In .Keys
            Sheets("Калькуляция").Cells(i, 1) = i-2
            Sheets("Калькуляция").Cells(i, 2) = vX
            Sheets("Калькуляция").Cells(i, 3) = Ed.Item(vX)
            Sheets("Калькуляция").Cells(i, 4) = .Item(vX)
            i = i + 1
        Next vX
    End With
    Set Ed = Nothing
End Sub

@CrazyTonik · 11.07.2014, 13:55 **[ТС]**

Вообще суперский макрос! Сейчас попробую с ним разобраться, чтобы подобный написать для других нужд. Ведь у меня куча ещё других таблиц, свести которые неплохо было бы.

@CrazyTonik · 14.07.2014, 10:29 **[ТС]**

Помогите разобраться. Вот есть оперкарта (точнее, их 60 на листе). И есть лимитка. Я немного переписал код, но что-то упустил. Почему не останавливается на материалах, и идёт дальше на нормы времени?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub Собрать_лимитку()
    Dim a(), i&, k%, Kolvo#, EdIzm$, Ed, vX
    Set Ed = CreateObject("Scripting.Dictionary")
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        With Sheets("ТЕХН")
            a = Intersect(.UsedRange, .Columns("E:N")).Value
        End With
        For i = 1 To UBound(a)
            a(i, 1) = Trim(a(i, 1))
            Select Case UCase(a(i, 1))
                Case "РАСЦЕНКА", "МАТЕРИАЛ", "ПОДПИСЬ БОТ", "МЕСТО", "ПРИНЯТО ГОДНЫХ", "ДАТА", "ПОДПИСЬ ОТК", ""
                Case Else
                    a(i, 10) = Trim(a(i, 10))
                    Kolvo = Val(Replace((a(i, 10)), ",", "."))
                    k = InStr(1, a(i, 10), " ")
                    EdIzm = IIf(k > 0, Trim(Right(a(i, 10), Len(a(i, 10)) - k)), "")
                    .Item(a(i, 1)) = .Item(a(i, 1)) + Kolvo
                    Ed.Item(a(i, 1)) = EdIzm
            End Select
        Next i
        k = .Count + 2
        With Sheets("ЛИМ")
            Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 4)).Clear
            Range(.Cells(3, 1), .Cells(k, 4)).Borders.LineStyle = xlContinuous
        End With
        i = 3
        For Each vX In .Keys
            Sheets("ЛИМ").Cells(i, 1) = i - 2
            Sheets("ЛИМ").Cells(i, 2) = vX
            Sheets("ЛИМ").Cells(i, 3) = Ed.Item(vX)
            Sheets("ЛИМ").Cells(i, 4) = .Item(vX)
            i = i + 1
        Next vX
    End With
    Set Ed = Nothing
End Sub

Аксима · 14.07.2014, 12:34

Сообщение от CrazyTonik

Почему не останавливается на материалах, и идёт дальше на нормы времени?

Мне кажется, это происходит потому, что у вас нет никакой привязки к материалам - вы просто проходите по столбцу "E" и ищете там непустые ячейки, значения которых не равны (без учета регистра) одному из следующих: "РАСЦЕНКА", "МАТЕРИАЛ", "ПОДПИСЬ БОТ", "МЕСТО", "ПРИНЯТО ГОДНЫХ", "ДАТА" или "ПОДПИСЬ ОТК".

Разве ячейки со значениями 2,2 или 4,5 не удовлетворяют такому критерию? Еще как удовлетворяют!

Предлагаю привязываться к заголовку "МАТЕРИАЛ", т.е. заменить следующие строчки вашего кода:

Visual Basic
1
2
3
4
5
6
7
8
9
10
            Select Case UCase(a(i, 1))
                Case "РАСЦЕНКА", "МАТЕРИАЛ", "ПОДПИСЬ БОТ", "МЕСТО", "ПРИНЯТО ГОДНЫХ", "ДАТА", "ПОДПИСЬ ОТК", ""
                Case Else
                    a(i, 10) = Trim(a(i, 10))
                    Kolvo = Val(Replace((a(i, 10)), ",", "."))
                    k = InStr(1, a(i, 10), " ")
                    EdIzm = IIf(k > 0, Trim(Right(a(i, 10), Len(a(i, 10)) - k)), "")
                    .Item(a(i, 1)) = .Item(a(i, 1)) + Kolvo
                    Ed.Item(a(i, 1)) = EdIzm
            End Select

На эти:

Visual Basic
1
2
3
4
5
6
7
8
9
            If UCase(a(i, 1)) = "МАТЕРИАЛ" Then
                i = i + 1
                a(i, 10) = Trim(a(i, 10))
                Kolvo = Val(Replace((a(i, 10)), ",", "."))
                k = InStr(1, a(i, 10), " ")
                EdIzm = IIf(k > 0, Trim(Right(a(i, 10), Len(a(i, 10)) - k)), "")
                .Item(a(i, 1)) = .Item(a(i, 1)) + Kolvo
                Ed.Item(a(i, 1)) = EdIzm
            End If

С уважением,

Aksima

@mc-black · 14.07.2014, 18:03

Выкладывайте тогда уж свой измененный файл, так как насколько понимаю в первом примере раньше не было норм времени.

Новые блоги и статьи Все статьи Все блоги /
Символьное дифференцирование igorrr37 13.02.2026 / * Логарифм записывается как: (x-2)log(x^2+2) - означает логарифм (x^2+2) по основанию (x-2). Унарный минус обозначается как ! */ #include <iostream> #include <stack> #include <cctype>. . .	Камера Toupcam IUA500KMA Eddy_Em 12.02.2026 Т. к. у всяких "хикроботов" слишком уж мелкий пиксель, для подсмотра в ESPriF они вообще плохо годятся: уже 14 величину можно рассмотреть еле-еле лишь на экспозициях под 3 секунды (а то и больше),. . .	И ясному Солнцу zbw 12.02.2026 И ясному Солнцу, и светлой Луне. В мире покоя нет и люди не могут жить в тишине. А жить им немного лет.	«Знание-Сила» zbw 12.02.2026 «Знание-Сила» «Время-Деньги» «Деньги -Пуля»
SDL3 для Web (WebAssembly): Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 12.02.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами и вызывать обработчики событий столкновения. . . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 11.02.2026 Содержание блога Библиотека SDL3 содержит встроенные инструменты для базовой работы с изображениями - без использования библиотеки SDL3_image. Пошагово создадим проект для загрузки изображения. . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL3_image 8Observer8 10.02.2026 Содержание блога Библиотека SDL3_image содержит инструменты для расширенной работы с изображениями. Пошагово создадим проект для загрузки изображения формата PNG с альфа-каналом (с прозрачным. . .	Установка Qt-версии Lazarus IDE в Debian Trixie Xfce volvo 10.02.2026 В общем, достали меня глюки IDE Лазаруса, собранной с использованием набора виджетов Gtk2 (конкретно: если набирать текст в редакторе и вызвать подсказку через Ctrl+Space, то после закрытия окошка. . .

@CrazyTonik 0 / 0 / 0 Регистрация: 10.07.2014 Сообщений: 41
	11.07.2014, 13:55 [ТС]
	Вообще суперский макрос! Сейчас попробую с ним разобраться, чтобы подобный написать для других нужд. Ведь у меня куча ещё других таблиц, свести которые неплохо было бы. 0

@mc-black 2786 / 718 / 106 Регистрация: 04.02.2011 Сообщений: 1,443
	14.07.2014, 18:03
	Выкладывайте тогда уж свой измененный файл, так как насколько понимаю в первом примере раньше не было норм времени. 0

Поиск нужного значения, фильтрация и суммирование

Решение