Страницы: 1
RSS
Как объединить суммы продаж по дням?
 
Есть таблица продаж, где одной продаже соотвествует одна строка.  
Номер    
продажи Дата    
        продажи Сумма  
                продажи  
1 22.03.11 40 050 руб.  
2 22.03.11 49 050 руб.  
3 22.03.11 49 050 руб.  
4 23.03.11 26 500 руб.  
5 23.03.11 61 050 руб.  
6 23.03.11 21 300 руб.  
7 23.03.11 28 000 руб.  
8 23.03.11 44 500 руб.  
9 23.03.11 35 550 руб.  
10 24.03.11 246 700 руб.  
11 25.03.11 53 400 руб.  
12 25.03.11 59 950 руб.  
13 25.03.11 59 950 руб.  
14 25.03.11 33 050 руб.  
15 25.03.11 14 200 руб.  
16 28.03.11 26 700 руб.  
17 28.03.11 44 500 руб.  
18 28.03.11 32 000 руб.  
19 28.03.11 35 500 руб.  
20 28.03.11 44 500 руб.  
21 28.03.11 44 500 руб.  
22 28.03.11 35 550 руб.  
23 28.03.11 74 550 руб.  
 
Надо на отдельном листе сделать таблицу, в которой бы автоматически объединялись все продажи за один день в одну строку. Вот так:  
 
Номер    
дня  
        Дата    
        продажи Сумма    
                 продажи за день  
1 22.03.11 138 150 руб.  
2 23.03.11 216 900 руб.  
3 24.03.11 246 700 руб.  
4 25.03.11 220 550 руб.  
5 26.03.11 0 руб.  
6 27.03.11 0 руб.  
7 28.03.11 311 100 руб.  
 
 
Как это сделать с помощью Excell?  
 
Спасибо.
 
=СУММЕСЛИ() попробуйте.
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
 
Или сводную таблицу.
 
Или макрос - обработайте по вкусу, я минимально готовый изменил.  
Нужно подкорректировать вывод, добавить формат области вывода, возможно изменить определение входного массива с помощью CurrentRegion.  
Хотя и так всё работает, если убрать вбок Ваш пример результата (мешает).  
 
Option Explicit  
 
Sub Otbor()  
   Dim a(), oDict As Object, i As Long, temp As String  
     
   a = Range("B1:C" & Range("B" & Rows.Count).End(xlUp).Row).Value  
 
   Set oDict = CreateObject("Scripting.Dictionary")  
   For i = 1 To UBound(a)  
       temp = UCase(Trim(a(i, 1)))  
       If Not oDict.Exists(temp) Then  
           oDict.Add temp, CStr(a(i, 2))  
       Else  
           oDict.Item(temp) = CStr(--oDict.Item(temp) + a(i, 2))  
       End If  
   Next  
 
   With ThisWorkbook.Worksheets(2)  
       .Range("D1").Resize(oDict.Count) = Application.Transpose(oDict.keys)  
       .Range("E1").Resize(oDict.Count) = Application.Transpose(oDict.items)  
   End With  
 
End Sub
 
{quote}{login=lig}{date=29.03.2011 05:00}{thema=Как объединить суммы продаж по дням?}{post}... Надо на отдельном листе сделать таблицу, в которой бы автоматически объединялись все продажи за один день в одну строку...{/post}{/quote}  
Не получится... в одну строку как у вас. Почему? Элементарно, lig: всего дней 7 (1- пнд... 7- вск), в месяце на 1 номер будет 4 даты... Далее, где в диапазоне определение номера дня недели?.. Если делать за вас, то как, где ставить... Словом, покумекать более требуется... ;)  
ps И, если это не учебно-тренировочное, то где ваши потуги?..  
-98739-
 
Кстати, только что чуть модифицировал это код для коллеги - ей вдруг понадобилось подсчитать именно суммы по уникальным в части большого списка.  
Пока она вручную подбила 4 позиции, переработал этот код - теперь он обрабатывает Selection.  
У коллеги рассчитано на 3 столбца - уникальные в первом, суммы в третьем, здесь в примере на два - под эту задачу.  
Результат выводится в новую книгу, откуда его можно скопипастить куда угодно.  
 
Sub Otbor()  
   Dim a(), oDict As Object, i As Long, temp As String  
     
   a = Selection.Value  
 
   Set oDict = CreateObject("Scripting.Dictionary")  
   For i = 1 To UBound(a)  
       temp = UCase(Trim(a(i, 1)))  
       If Not oDict.Exists(temp) Then  
           oDict.Add temp, CStr(a(i, 2))  
       Else  
           oDict.Item(temp) = CStr(--oDict.Item(temp) + a(i, 2))  
       End If  
   Next  
 
   With Workbooks.Add.Worksheets(1)  
       .Range("D1").Resize(oDict.Count) = Application.Transpose(oDict.keys)  
       .Range("E1").Resize(oDict.Count) = Application.Transpose(oDict.items)  
   End With  
 
End Sub
 
Универсальный вариант, может кому пригодится (нам уже пригодился):  
 
Option Explicit  
Option Compare Text  
 
Sub UniqSummUniversal()  
'Выделить диапазон, где в первом столбце - уникальные.  
'На запрос ввести номер столбца с суммируемым количеством в выделенном  
   Dim a(), oDict As Object, i As Long, temp As String  
   Dim ind As Long  
   ind = InputBox("Sum Column Number?")  
   a = Selection.Value  
 
   Set oDict = CreateObject("Scripting.Dictionary")  
   For i = 1 To UBound(a)  
   If IsNumeric(a(i, ind)) Then  
   If Not IsEmpty(a(i, ind)) Then  
       temp = Trim(a(i, 1))  
       If Not oDict.Exists(temp) Then  
           oDict.Add temp, CStr(a(i, ind))  
       Else  
           oDict.Item(temp) = CStr(--oDict.Item(temp) + a(i, ind))  
       End If  
   End If  
   End If  
   Next  
 
   On Error Resume Next  
   With Workbooks.Add.Worksheets(1)  
       .Range("A1").Resize(oDict.Count) = Application.Transpose(oDict.keys)  
       .Range("B1").Resize(oDict.Count) = Application.Transpose(oDict.items)  
   End With  
   On Error GoTo 0  
     
End Sub
 
Думаю, можно код переделать - запрос колонки с суммами лишнее. Просто выделяем от столбца с анализируемыми данными по столбец с суммами.
 
Модифицировал.
 
В предыдущем файле есть недоработка - регистр букв имеет значение.  
Если регистром нужно пренебречь - берите этот файл.
 
Убрал Transpose - сразу набираем данные в массив, который будем выгружать.  
Немного изменил по мелочи для ускорения.  
42000 строк с 4-мя уникальными обрабатывает за полсекунды.  
 
Option Explicit  
 
Sub UniqSummUniversal() 'вариант без Transpose - для больших объёмов  
'Выделить диапазон, где в первом столбце - неуникальные, в последнем - суммы  
Dim a(), b(), oDict As Object, i&, ii&, temp$, x&  
Dim ind&  
'Dim tm: tm = Timer  
a = Selection.Value  
ReDim b(1 To UBound(a, 1), 1 To 2)  
ind = UBound(a, 2)  
Set oDict = CreateObject("Scripting.Dictionary")  
oDict.CompareMode = 1  
For i = 1 To UBound(a)  
   If Not IsEmpty(a(i, ind)) Then  
       If IsNumeric(a(i, ind)) Then  
       temp = Trim(a(i, 1))  
           If Not oDict.Exists(temp) Then  
           ii = ii + 1  
           b(ii, 1) = temp: b(ii, 2) = a(i, ind)  
           oDict.Add temp, CStr(ii)  
           Else  
           x = oDict.Item(temp)  
           b(x, 2) = b(x, 2) + a(i, ind)  
           End If  
       End If  
   End If  
Next  
 
On Error Resume Next 'если вдруг ii=0  
With Workbooks.Add.Worksheets(1)  
.Range("A1:B1").Resize(ii) = b  
End With  
On Error GoTo 0  
'Debug.Print Timer - tm  
End Sub
 
Чуть исправил код - сегодня обнаружил, что уникальные вида "1197." хоть и отбираются правильно, но при выгрузке на лист точка исчезает, что неправильно.  
Теперь сперва этому столбцу задаётся текстовый формат, затем выгружаются данные.
 
Упс, предыдущая версия с Transpose проскочила...  
Лучше эта - чуть исправленный вариант post_232779.xls
 
Мне ваш макрос почти помог. Только мне надо, что бы сумировал последний столбец если повторение в первых трех.    
Прикреплен мой случай.
 
попробуйте так:  
 
Sub Bandanas1()  
Dim Summa  
Dim iLastRow As Long  
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row  
For i = 2 To iLastRow  
Summa = Cells(i, 4)  
For j = iLastRow To i + 1 Step -1  
If Cells(j, 1) = Cells(i, 1) Then  
   If Cells(j, 2) = Cells(i, 2) Then  
       If Cells(j, 3) = Cells(i, 3) Then  
           Summa = Summa + Cells(j, 4)  
           Rows(j).Delete  
           iLastRow = iLastRow - 1  
       End If  
   End If  
End If  
Cells(i, 4) = Summa  
Next  
Next  
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row  
Cells(2, 1) = 1  
For n = 3 To iLastRow  
Cells(n, 1) = n - 1  
Next  
End Sub  
 
Все "спасибы" Hugo ; )
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


https://github.com/nervgh
 
Ппросто супер, только одно но, он ячейки в первом столбце переименовывает, а пронумеровывает попорядку
 
Очень жду помощи, сестра сказала вас расцелует :) Я как узнал что ей надо будет дня 2 сидеть париться с отчетами, решил помочь, у самого ничего не вышло, вот, к вам пришел.
 
объясните еще раз, что Вас не устраивает в предыдущем примере?
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


https://github.com/nervgh
 
Впринципе ваш макрос все делает правильно, за исключением одного, переименовывает все строки в первом столбце (нумерует их попорядку, затирая тем самым данные) немного выше прикреплен файл где это видно.
 
попробуйте это
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


https://github.com/nervgh
 
sserenkiy, я бы сделал так, чтоб не писать новый макрос:  
1. левее сумм создал столбец, куда собрал данные из первых трёх через разделитель формулой  
=B1&"|"&C1&"|"&D1  
это я в А собирал, но не принципиально.  
2. макросом получил сводную типа  
44550|225|40724 11,16  
3. Инструментом "текст по столбцам" опять получил столбцы.  
Но правда в Вашем примере всё дело портит перевод строки в первом столбце, его сперва нужно заменой убрать.
 
Да, в итоге из 40724 получаем 30.06.2011 заменой формата столбца на "дата"
 
Чуть изменил код - добавил вывод ещё и количества повторов.  
Если ненужно - просто игнорируйте этот столбец.  
Плюс ещё есть небольшое изменение в коде - стало лучше :)  
 
В архиве версия  
UniqSummUniversal.v7(.Comparemode=1).xls
 
Игорь, мне кажется, что для универсальности (я имею ввиду, чтобы людям было проще), лучше добавить такой код в начале кода  
 
   If Selection.Cells.Count = 1 Then  
       MsgBox "Выделите данные на листе!" & Chr(10) & "В левом столбце даты продаж, в правом суммы", vbInformation, ""  
       Exit Sub  
   End If  
 
 
Иначе у людей всегда первый запуск будет вызывать ошибку и люди будут думать, что код не работает
 
я к тому, что мало людей, кто читает инструкции ))    
 
P.S. Хоть я и прочёл инструкции и на листе и в коде, но всё равно попытался сразу запустить код ))))
 
Теперь уже поздно :)  
В следующей версии. Хотя вроде уже всё, что туда ещё добавить... Диалог выбора файла и столбцов что-ли? Вроде лишнее...  
А сегодня я добавил подсчёт потому, что на другом форуме человеку это было нужно, а т.к. он код подправить сам не мог, он его по два раза запускал - сперва собирал суммы, потом столбец с единицами :)  
Теперь сразу всё есть - а кому количество повторов не нужно, могут столбец не копировать или удалить.
 
да, макрос хороший и очень хорошо написан. Многим будет полезен.  
 
Я хоть и не сталкиваюсь с проблемами в Excel'e, как многие топикстартеры, но им иногда завидую. Вот человек столкнулся с проблемой и не знает, как её решить (или быстро решить). Приходи к нам, мы ему помогаем и он счастлив "до соплей", теперь у него всё получилось, теперь работа будет делаться во много раз быстрее )
 
Hugo, дорботайте пожалуйста Ваш супер полезный макрос, чтобы в итоговом файле стало 4 столбца:  
 
В итоговом новом файле будут 4 столбца:  
1. уникальные  
2. суммы  
3. суммы  
4. сколько раз встретилось уникальное (количество повторов)
 
Доработать можно - вот только что за вторые суммы?  
Если Вы хотите видеть все суммы, из которых собрана итоговая - то просто отсортируйте исходный массив и увидите.  
А пихать их через запятую в одну ячейку думаю не стоит - это и работу затормозит, и они могут просто не поместиться в ячейку, если диапазон большой.  
Кроме того, в копилке есть UDF VLOOKUPCOUPLE() как раз для этой задачи.  
Но сделать конечно можно - может быть чуть позже сделаю с выключателем этого дела на первом листе :)
 
Сделал вариант на 4 столбца с "выключателями" на первом листе файла с макросом.  
Как и предполагал, есть узкое место с выгрузкой собранных длинных строк на лист.  
Причём длинная строка из массива размером с одну ячейку выгружается нормально (пробовал до 5000 символов), а если массив на 2 ячейки - то у меня на 2003 всё загибается уже на длине строки в 911 символов.  
Но если первый символ минус (отрицательная сумма), то всё ещё хуже. Поэтому перед строкой сумм добавляю апостоф - это благотворно влияет на минусы :)  
Так что сделал выгрузку этого массива перебором, и в случае ошибки с выгрузкой элемента массива с длинной строкой вместо этой строки будет надпись "Error!!!".  
В этом варианте нет ошибок и при выгрузке строки длиной 23614 с минусом впереди.  
 
И кстати совет "хто-та" тоже применил :)
Страницы: 1
Наверх