Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
суммирование текстовых значений по критерию
 
#1
23.02.2010 10:47:49
Всех мужчин с праздником Защитников отечества.  
Однако.  
Существует таблица. В ней необходимо выбрать и "сложить" (соединить в одной ячейке D2) не одинаковые по значению, но одинаковые по критерию.    
Теперь более подробно.  
Колонка А - критерий ("сера")  
Колонка В - значения  
В ячейке D2 - должно быть следующее "qwe1, qwe2,qwe3,qwe4" (исходя из прикрепленной ткниги).    
Я уже "сломал" себе голову, изчеркал огромное кол-во листов схемами, и алгаритмами, но так и не могу найти ошибку в своих умозаключениях. Поэтому решил обратиться на форум. ПОМОГИТЕ исправить мою ошибку в макросе или наставте на правильный путь если все сделаное мною неверно.  
Не судите строго за простоту написания макроса (пока способен только на такое).  
Заранее благодарен.
 
 
 
#2
23.02.2010 10:58:32
За пару минут накидал макрос:  
 
Sub test()  
   Dim cell As Range, cell2 As Range, ra1 As Range, ra2 As Range  
   Application.ScreenUpdating = False: On Error Resume Next  
   Set ra1 = Range([A1], Range("A" & Rows.Count).End(xlUp))
   For Each cell In ra1.Cells  
       If Len(cell) Then  
           Set ra2 = Range(cell.Offset(1), Range("A" & Rows.Count).End(xlUp))  
           For Each cell2 In ra2.Cells  
               If cell2 = cell Then  
                   If Not cell.Next.Next Like cell2.Next.Next & ", *" Then  
                       cell.Next.Next = cell.Next.Next & ", " & cell2.Next.Next:  
                   End If  
                   cell2 = ""  
               End If  
           Next cell2  
       End If  
   Next cell  
   ra1.Offset(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete  
End Sub  
 
 
 
Он далеко не самый оптимальный, но работает.  
 
Пример - в файле: http://excelvba.ru/XL_Files/Sample__23-02-2010__12-59-20.zip
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#3
23.02.2010 16:28:09
{quote}{login=EducatedFool}{date=23.02.2010 10:58}{thema=}{post}За пару минут накидал макрос:  
 
Sub test()  
   Dim cell As Range, cell2 As Range, ra1 As Range, ra2 As Range  
   Application.ScreenUpdating = False: On Error Resume Next  
   Set ra1 = Range([A1], Range("A" & Rows.Count).End(xlUp))
   For Each cell In ra1.Cells  
       If Len(cell) Then  
           Set ra2 = Range(cell.Offset(1), Range("A" & Rows.Count).End(xlUp))  
           For Each cell2 In ra2.Cells  
               If cell2 = cell Then  
                   If Not cell.Next.Next Like cell2.Next.Next & ", *" Then  
                       cell.Next.Next = cell.Next.Next & ", " & cell2.Next.Next:  
                   End If  
                   cell2 = ""  
               End If  
           Next cell2  
       End If  
   Next cell  
   ra1.Offset(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete  
End Sub  
 
 
 
 
 
Он далеко не самый оптимальный, но работает.  
 
Пример - в файле: http://excelvba.ru/XL_Files/Sample__23-02-2010__12-59-20.zip{/post}{/quote}  
 
Большое спасибо. Но происходит изменение таблицы с данными, а этого происходить не должно. Результат должен выводиться в отдельную именованную ячейку. Я могу адаптировать данный макрос для себя, если можно описать действия в нем (кратко)
 
 
 
#4
23.02.2010 17:13:53
{quote}{login=}{date=23.02.2010 04:28}{thema=Re: }{post}{quote}{login=EducatedFool}{date=23.02.2010 10:58}{thema=}{post}За пару минут накидал макрос:  
 
Sub test()  
   Dim cell As Range, cell2 As Range, ra1 As Range, ra2 As Range  
   Application.ScreenUpdating = False: On Error Resume Next  
   Set ra1 = Range([A1], Range("A" & Rows.Count).End(xlUp))
   For Each cell In ra1.Cells  
       If Len(cell) Then  
           Set ra2 = Range(cell.Offset(1), Range("A" & Rows.Count).End(xlUp))  
           For Each cell2 In ra2.Cells  
               If cell2 = cell Then  
                   If Not cell.Next.Next Like cell2.Next.Next & ", *" Then  
                       cell.Next.Next = cell.Next.Next & ", " & cell2.Next.Next:  
                   End If  
                   cell2 = ""  
               End If  
           Next cell2  
       End If  
   Next cell  
   ra1.Offset(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete  
End Sub  
 
 
 
 
 
Он далеко не самый оптимальный, но работает.  
 
Пример - в файле: http://excelvba.ru/XL_Files/Sample__23-02-2010__12-59-20.zip{/post}{/quote}  
 
Большое спасибо. Но происходит изменение таблицы с данными, а этого происходить не должно. Результат должен выводиться в отдельную именованную ячейку. Я могу адаптировать данный макрос для себя, если можно описать действия в нем (кратко){/post}{/quote}  
И еще хочу добавить, что одинаковые данный в результате не должны повторяться (т.е. не должно быть так "qwe1, qwe1, qwe3, qwe1, qwe3", а должно быть - "qwe1, qwe3")
 
 
 
#5
23.02.2010 17:35:52
Для операции "не повторяться" у меня есть код, можно использовать.  
Может его можно улучшить, но пока такой.  
Dim rba As Range - Public, определяется в другой процедуре.  
Рассчитано на обработку ячеек, где повторяются значения именно через запятую:  
 
Sub KorrList()  
Dim cc As Range  
Dim arrtwo() As String  
Dim arr() As String  
Dim unik As Boolean  
Dim i As Integer  
Dim x As Integer  
Dim y As Integer  
Dim temp$  
unik = True  
For Each cc In rba.Cells  
Erase arrtwo()  
ReDim Preserve arrtwo(0)  
 
   arr = Split(cc.Value, ",") 'массив из исходного текста  
   For i = LBound(arr) To UBound(arr)  
       temp = Trim(arr(i))  
           For x = LBound(arrtwo) To UBound(arrtwo)  
               If UCase(temp) = UCase(Trim(arrtwo(x))) Then unik = False  
               Next  
               If unik Then  
                   ReDim Preserve arrtwo(UBound(arrtwo) + 1)  
                   arrtwo(UBound(arrtwo)) = temp  
               End If  
               unik = True  
           Next  
   cc.Value = ""  
   For y = LBound(arrtwo) + 1 To UBound(arrtwo)  
       If cc.Value = "" Then  
       cc.Value = arrtwo(y)  
       Else  
       cc.Value = cc.Value & ", " & arrtwo(y)  
       End If  
   Next  
Next  
End Sub
 
 
 
#6
23.02.2010 18:09:34
Для меня - сложновато разобраться. Может можно как-нибудь проще...
 
 
 
#7
23.02.2010 18:21:57
{quote}{login=sdoman}{date=23.02.2010 06:09}{thema=сложновато}{post}Для меня - сложновато разобраться. Может можно как-нибудь проще...{/post}{/quote}  
Вообще-то это только то, чем можно потом сделать из ваших "qwe1, qwe3, qwe1, qwe3" набор уникальных значений.  
Принцип простой - грузим значение ячейки в массив, перекладываем только уникальные в другой массив, его выгружаем обратно в ячейку. Ничего готового не нашёл, пришлось такое городить, может можно и проще, не знаю.
 
 
 
#8
24.02.2010 12:58:00
В колонке (кол-во строк может доходить до 50) собираются по критерию "ЛДСП 10 мм" данные из таблицы "Табл". Для этого макрос я создал, а далее стопор, знаю что надо сделать, а как - не знаю. Далее (это последняя строка в колонке зеленого цвета) необходимо перенести все не одинаковые значения из колонки зеленого цвета. Дать этой ячейке ИМЯ (пусть будет "itog_end").  
Думаю, что эти данные нужно обозначить как массив и выгрузить не одинаковые значения в последнюю ячейку колонки (в данном случае желтого цвета). Цвет не имеет никакого отношения к решению задачи, это просто для наглядности. Просьба в помощи обозначения и выгрузки массива (у меня это не получается - "не догоняю"). Желательно Макросом. См. вложенный файл.
 
 
 
#9
24.02.2010 13:14:01
Ну так выше почти готовый код - замени в нём первый массив на твою колонку (в смысле данные) и укажи ячейку для выгрузки. Мне это делать уже неинтересно...
 
 
 
Страницы: 1
Читают тему
Наверх