Выполнить подсчет данных по сотруднику за месяц

Старая форма входа

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

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выполнить подсчет данных по сотруднику за месяц (Макросы/Sub)

Vladimir32

Дата: Вторник, 05.02.2019, 22:21 | Сообщение № 1

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

Ранг: Новичок

Сообщений: 34

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

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

Excel 2016

Коллеги, добрый вечер.
Очень нужна Ваша помощь.
В большом файле находится информация, сколько каждый сотрудник продает товара за день, и какую получает оценку.
Задача состоит в том, чтобы на лист 2 вывести информацию: напротив каждого сотрудника - сколько каждый сотрудник продал товара (в виде суммы товара) и какое количество оценок оценок он получил.
Моих мозгов хватает только чтобы посчитать просто кол-во товара сколько продал сотрудник.
Через формулу счет если считается оценка, но нюанс в том, что файл на выходе получается очень большой, и формула работает около часа, что очень долго(
Помогите пожалуйста в решении данной задачи.

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

Ответить

Pelena

Дата: Вторник, 05.02.2019, 22:47 | Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 19179

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

Замечаний: ±

Excel 365 & Mac Excel

Здравствуйте.
Сводная не подойдет?

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

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Vladimir32

Дата: Среда, 06.02.2019, 07:58 | Сообщение № 3

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

Ранг: Новичок

Сообщений: 34

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

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

Excel 2016

К сожалению сводная не подходит, в дальнейшем таблица будет больше, и обновляется будет автоматически обновляется. Пытался делать с помощью массива, но он просто выводит по дате и ФИО просто данные с первого листа, как их посчитать мозгов не хватает. Думал добавить еще столбец с номером месяца, это тоже ничего не дало.

Ответить

_Boroda_

Дата: Среда, 06.02.2019, 09:51 | Сообщение № 4

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16675

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

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

2003; 2007; 2010; 2013 RUS

Сводную всегда можно сделать по бОльшему диапазону (в примере сделано на все строки Excel)
Запускать макрос Вы все равно будете вручную, для того у Вас там кнопка и висит, так ведь? Ну вот и повесим на эту кнопку макрос обновления сводной

А если у Вас данных много, то сводная таблица - наилучший по скорости вариант

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

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

Vladimir32

Дата: Среда, 06.02.2019, 10:21 | Сообщение № 5

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

Ранг: Новичок

Сообщений: 34

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

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

Excel 2016

Что касается скорости вы совершенно правы, сводная наилучший вариант. Там проблема в том, что таблица имеет определенный формат (своеобразная консолидации). Кнопку туда кинул, так как тестировал как их вытащить. Потом из этого файла будут по логин вытягиватся данные за месяц, на панель. Т.е. руководитель открывает панель, вводит ФИО сотрудника, и должны появится его показатели за 1 месяц.
Из сводной ведь нельзя так вытащить данные?

Ответить

Roman777

Дата: Среда, 06.02.2019, 10:26 | Сообщение № 6

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

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

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

Excel 2007, Excel 2013

Vladimir32, Проверил только по суммам, но вроде должно работать:
[vba]

Код

Sub Commonate()
    Dim i&, j&, tmp As Variant
    Dim o As Object, key$, oDates As Object, dat$
    Dim Names$(), k&
    Dim t(1 To 2) As Long
    Dim AllDates As Object, datas$(), k2&
    Dim tmpDat As Variant
    Set o = CreateObject("Scripting.dictionary")
    Set AllDates = CreateObject("Scripting.dictionary")
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        key = Cells(i, 1)
        dat = Format(Cells(i, 2), "MM.YYYY")
        If (Not o.exists(key)) Then
            k = k + 1
            ReDim Preserve Names(1 To k)
            Names(k) = key
            Set oDates = CreateObject("Scripting.dictionary")
            If (Not oDates.exists(dat)) Then
                For j = 1 To 2
                    t(j) = Cells(i, 2 + j)
                Next j
                oDates.Add dat, t
            Else
                Set tmp = oDates(dat)
                For j = 1 To 2
                    tmp(j) = tmp(j) + Cells(i, 2 + j)
                Next j
            End If
            o.Add key, oDates
        Else
            Set tmpDat = o(key)
            If (Not tmpDat.exists(dat)) Then
                For j = 1 To 2
                    t(j) = Cells(i, 2 + j)
                Next j
                tmpDat.Add dat, t
            Else
                tmp = tmpDat(dat)
                For j = 1 To 2
                    tmp(j) = tmp(j) + Cells(i, 2 + j)
                Next j
                tmpDat(dat) = tmp
            End If
            Set o(key) = tmpDat
        End If
        If (Not AllDates.exists(dat)) Then
            k2 = k2 + 1
            ReDim Preserve datas(1 To k2)
            datas(k2) = dat
            AllDates.Add dat, 1
        End If
    Next i
    k = UBound(Names)
    With Worksheets(2)
        For i = 1 To UBound(datas)
            For j = 1 To k
                k2 = i + (k - 1) * (i - 1) + j
                .Cells(k2, 1) = Names(j)
                If AllDates.exists(datas(i)) Then
                    .Cells(k2, 2) = MonthName(Month(datas(i))) & " " & Year(datas(i))
                    Set tmp = o(Names(j))
                    .Cells(k2, 3) = tmp(datas(i))(1)
                    .Cells(k2, 4) = tmp(datas(i))(2)
                Else
                    .Cells(k2, 2) = MonthName(Month(datas(i))) & " " & Year(datas(i))
                    .Cells(k2, 3) = 0
                    .Cells(k2, 4) = 0
                End If
            Next j
        Next i
    End With
End Sub

[/vba]

Vladimir32, Проверил только по суммам, но вроде должно работать:
[vba]

Код

[/vba]Roman777

Много чего не знаю!!!!

Ответить

СообщениеVladimir32, Проверил только по суммам, но вроде должно работать:
[vba]

Код

[/vba]

Автор - Roman777
Дата добавления - 06.02.2019 в 10:26

_Boroda_

Дата: Среда, 06.02.2019, 10:48 | Сообщение № 7

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16675

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

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

2003; 2007; 2010; 2013 RUS

Цитата Vladimir32, 06.02.2019 в 10:21, в сообщении № 5 ()

Из сводной ведь нельзя так вытащить данные?

Льзя. Смотрите файл

И в следующий раз не нужно вот этих подходов издалека. Сразу говорите что конкретно нужно

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

Ответить

Vladimir32

Дата: Среда, 06.02.2019, 15:32 | Сообщение № 8

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

Ранг: Новичок

Сообщений: 34

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

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

Excel 2016

_Boroda_, спасибо! Очень удобно получилось.

Ответить

Vladimir32

Дата: Среда, 06.02.2019, 15:34 | Сообщение № 9

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

Ранг: Новичок

Сообщений: 34

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

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

Excel 2016

Roman777, спасибо за макрос, сумму он считает отлично. А вот вопрос, я пытался его "поковырять", чтобы он кол-во считал, но не получается(

Ответить

Roman777

Дата: Среда, 06.02.2019, 20:51 | Сообщение № 10

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

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

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

Excel 2007, Excel 2013

Vladimir32, добрый вечер!

Цитата Vladimir32, 06.02.2019 в 15:34, в сообщении № 9 ()

я пытался его "поковырять", чтобы он кол-во считал, но не получается

а я не вижу, где Вы пытались...) А про какое количество идёт речь?

Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Среда, 06.02.2019, 20:57

Ответить

Vladimir32

Дата: Четверг, 07.02.2019, 07:50 | Сообщение № 11

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

Ранг: Новичок

Сообщений: 34

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

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

Excel 2016

Файл пока не могу приложить, с рабочего компьютера нельзя файлы прикладывать, в столбце оценка есть стоят оценки от 1 до 5, и нужно посчитать количество оценок, а не сумму.

Ответить

Roman777

Дата: Четверг, 07.02.2019, 11:26 | Сообщение № 12

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

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

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

Excel 2007, Excel 2013

Vladimir32, поидее так должно работать:
[vba]

Код

Sub Commonate()
    Dim i&, j&, tmp As Variant
    Dim o As Object, key$, oDates As Object, dat$
    Dim Names$(), k&
    Dim t(1 To 2) As Long
    Dim AllDates As Object, datas$(), k2&
    Dim tmpDat As Variant
    Set o = CreateObject("Scripting.dictionary")
    Set AllDates = CreateObject("Scripting.dictionary")
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        key = Cells(i, 1)
        dat = Format(Cells(i, 2), "MM.YYYY")
        If (Not o.exists(key)) Then
            k = k + 1
            ReDim Preserve Names(1 To k)
            Names(k) = key
            Set oDates = CreateObject("Scripting.dictionary")
            If (Not oDates.exists(dat)) Then
                    t(1) = Cells(i, 3)
                    t(2) = 1
                oDates.Add dat, t
            Else
                Set tmp = oDates(dat)
                    tmp(1) = tmp(1) + Cells(i, 3)
                    tmp(2) = tmp(2) + 1
            End If
            o.Add key, oDates
        Else
            Set tmpDat = o(key)
            If (Not tmpDat.exists(dat)) Then
                    t(1) = Cells(i, 3)
                    t(2) = 1
                tmpDat.Add dat, t
            Else
                tmp = tmpDat(dat)

                    tmp(1) = tmp(1) + Cells(i, 3)
                    tmp(2) = tmp(2) + 1
                tmpDat(dat) = tmp
            End If
            Set o(key) = tmpDat
        End If
        If (Not AllDates.exists(dat)) Then
            k2 = k2 + 1
            ReDim Preserve datas(1 To k2)
            datas(k2) = dat
            AllDates.Add dat, 1
        End If
    Next i
    k = UBound(Names)
    With Worksheets(2)
        For i = 1 To UBound(datas)
            For j = 1 To k
                k2 = i + (k - 1) * (i - 1) + j
                .Cells(k2, 1) = Names(j)
                If AllDates.exists(datas(i)) Then
                    .Cells(k2, 2) = MonthName(Month(datas(i))) & " " & Year(datas(i))
                    Set tmp = o(Names(j))
                    .Cells(k2, 3) = tmp(datas(i))(1)
                    .Cells(k2, 4) = tmp(datas(i))(2)
                Else
                    .Cells(k2, 2) = MonthName(Month(datas(i))) & " " & Year(datas(i))
                    .Cells(k2, 3) = 0
                    .Cells(k2, 4) = 0
                End If
            Next j
        Next i
    End With
End Sub

[/vba]

Vladimir32, поидее так должно работать:
[vba]

Код

Sub Commonate()
    Dim i&, j&, tmp As Variant
    Dim o As Object, key$, oDates As Object, dat$
    Dim Names$(), k&
    Dim t(1 To 2) As Long
    Dim AllDates As Object, datas$(), k2&
    Dim tmpDat As Variant
    Set o = CreateObject("Scripting.dictionary")
    Set AllDates = CreateObject("Scripting.dictionary")
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        key = Cells(i, 1)
        dat = Format(Cells(i, 2), "MM.YYYY")
        If (Not o.exists(key)) Then
            k = k + 1
            ReDim Preserve Names(1 To k)
            Names(k) = key
            Set oDates = CreateObject("Scripting.dictionary")
            If (Not oDates.exists(dat)) Then
                    t(1) = Cells(i, 3)
                    t(2) = 1
                oDates.Add dat, t
            Else
                Set tmp = oDates(dat)
                    tmp(1) = tmp(1) + Cells(i, 3)
                    tmp(2) = tmp(2) + 1
            End If
            o.Add key, oDates
        Else
            Set tmpDat = o(key)
            If (Not tmpDat.exists(dat)) Then
                    t(1) = Cells(i, 3)
                    t(2) = 1
                tmpDat.Add dat, t
            Else
                tmp = tmpDat(dat)

                    tmp(1) = tmp(1) + Cells(i, 3)
                    tmp(2) = tmp(2) + 1
                tmpDat(dat) = tmp
            End If
            Set o(key) = tmpDat
        End If
        If (Not AllDates.exists(dat)) Then
            k2 = k2 + 1
            ReDim Preserve datas(1 To k2)
            datas(k2) = dat
            AllDates.Add dat, 1
        End If
    Next i
    k = UBound(Names)
    With Worksheets(2)
        For i = 1 To UBound(datas)
            For j = 1 To k
                k2 = i + (k - 1) * (i - 1) + j
                .Cells(k2, 1) = Names(j)
                If AllDates.exists(datas(i)) Then
                    .Cells(k2, 2) = MonthName(Month(datas(i))) & " " & Year(datas(i))
                    Set tmp = o(Names(j))
                    .Cells(k2, 3) = tmp(datas(i))(1)
                    .Cells(k2, 4) = tmp(datas(i))(2)
                Else
                    .Cells(k2, 2) = MonthName(Month(datas(i))) & " " & Year(datas(i))
                    .Cells(k2, 3) = 0
                    .Cells(k2, 4) = 0
                End If
            Next j
        Next i
    End With
End Sub

[/vba]Roman777

Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Четверг, 07.02.2019, 11:28

Ответить

СообщениеVladimir32, поидее так должно работать:
[vba]

Код

Sub Commonate()
    Dim i&, j&, tmp As Variant
    Dim o As Object, key$, oDates As Object, dat$
    Dim Names$(), k&
    Dim t(1 To 2) As Long
    Dim AllDates As Object, datas$(), k2&
    Dim tmpDat As Variant
    Set o = CreateObject("Scripting.dictionary")
    Set AllDates = CreateObject("Scripting.dictionary")
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        key = Cells(i, 1)
        dat = Format(Cells(i, 2), "MM.YYYY")
        If (Not o.exists(key)) Then
            k = k + 1
            ReDim Preserve Names(1 To k)
            Names(k) = key
            Set oDates = CreateObject("Scripting.dictionary")
            If (Not oDates.exists(dat)) Then
                    t(1) = Cells(i, 3)
                    t(2) = 1
                oDates.Add dat, t
            Else
                Set tmp = oDates(dat)
                    tmp(1) = tmp(1) + Cells(i, 3)
                    tmp(2) = tmp(2) + 1
            End If
            o.Add key, oDates
        Else
            Set tmpDat = o(key)
            If (Not tmpDat.exists(dat)) Then
                    t(1) = Cells(i, 3)
                    t(2) = 1
                tmpDat.Add dat, t
            Else
                tmp = tmpDat(dat)

                    tmp(1) = tmp(1) + Cells(i, 3)
                    tmp(2) = tmp(2) + 1
                tmpDat(dat) = tmp
            End If
            Set o(key) = tmpDat
        End If
        If (Not AllDates.exists(dat)) Then
            k2 = k2 + 1
            ReDim Preserve datas(1 To k2)
            datas(k2) = dat
            AllDates.Add dat, 1
        End If
    Next i
    k = UBound(Names)
    With Worksheets(2)
        For i = 1 To UBound(datas)
            For j = 1 To k
                k2 = i + (k - 1) * (i - 1) + j
                .Cells(k2, 1) = Names(j)
                If AllDates.exists(datas(i)) Then
                    .Cells(k2, 2) = MonthName(Month(datas(i))) & " " & Year(datas(i))
                    Set tmp = o(Names(j))
                    .Cells(k2, 3) = tmp(datas(i))(1)
                    .Cells(k2, 4) = tmp(datas(i))(2)
                Else
                    .Cells(k2, 2) = MonthName(Month(datas(i))) & " " & Year(datas(i))
                    .Cells(k2, 3) = 0
                    .Cells(k2, 4) = 0
                End If
            Next j
        Next i
    End With
End Sub

[/vba]

Автор - Roman777
Дата добавления - 07.02.2019 в 11:26

Vladimir32

Дата: Четверг, 07.02.2019, 13:37 | Сообщение № 13

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

Ранг: Новичок

Сообщений: 34

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

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

Excel 2016

Роман, это то что нужно наиогромнейшее спасибо!

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выполнить подсчет данных по сотруднику за месяц (Макросы/Sub)

Страница 1 из 1
1