[Iska]

a_axe, на мой взгляд — вполне подойдёт. Но подождём мнения автора.

[dyshes90]

Доброго дня, сводная таблица впр не плохо, я рассматривал этот вариант, но в примере всего 3 ячейки, на деле их будет 16-20, не совсем удобно просматривать данные будет на ней, всетки с моим примером по проще.

[dyshes90]

Iska, Есть идеи какие-нибудь, сроки горят, начальство вазилин готовит для меня)

[Iska]

dyshes90, я не вижу, чем бы это было неудобно.

Iska, Есть идеи какие-нибудь »

Есть. Использовать предложенный вариант со сводной таблицей.

[dyshes90]

Iska, Нет, не катит, вариант не удачный, неудобный для работы. Закрываю тему если мыслей нет.....

[a_axe]

не совсем удобно просматривать данные будет на ней »

Что именно неудобно и как нужно изменить, чтобы стало удобно?

на деле их будет 16-20 »

действительно, к Вам даже просьба была в этой связи:

dyshes90, ну, так покажите какой-нибудь реальный пример. »

Как вариант - можно сделать 26 сводных (бред конечно, но раз возникло расплывчатое слово "удобно") сводных таблиц по одной на каждого смурфика-фиксика в стиле Вашего файла (вообще четких критериев Вы не дали, поэтому совпадение условное) - в приложенном файле зеленые таблички. Сразу говорю, что замучаетесь их обновлять при изменении данных.

Ну и промежуточный (нормальный ) вариант - сделать все же одну сводную таблицу слегка в другой компоновке (в приложенном файле синяя таблица). В ней нажатием на крестик можно разворачивать/сворачивать наименование фильма. Нужна позиция - развернули, не нужна - свернули. Обновлять ее нужно только один раз.

Не зная Ваших критериев, на основании несодержательных и неконкретных комментариев "вариант не удачный, неудобный для работы" вряд ли получится реализовать более вдумчивое решение, потрудитесь хотя бы сказать, что для Вас удобно, что нет. Если нет желания расписывать, что Вы хотите иметь на выходе - мыслей и предложений нет.

[dyshes90]

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

[Iska]

dyshes90, мой вариант извлечения — посредством OLE DB (Office 2003):

Код:

Sub Sample()
    Dim objConnection As Object
    Dim objRecordSet1 As Object
    Dim objRecordSet2 As Object
    
    Dim objCurRegion As Range
    
    
    Set objConnection = CreateObject("ADODB.Connection")
    
    With objConnection
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = _
            "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 8.0;HDR=Yes;"""
        .Open
    End With
    
    Set objCurRegion = ThisWorkbook.Worksheets.Item("Адресная программа").Range("B2").CurrentRegion
    
    Set objRecordSet1 = objConnection.Execute( _
            "SELECT DISTINCT Наименование " & _
            "FROM [Адресная программа$" & objCurRegion.Address(False, False) & "] " & _
            "WHERE NOT Наименование IS NULL ORDER BY Наименование" _
        )
    
    Set objRecordSet2 = objConnection.Execute( _
            "SELECT Наименование, Ячейки, Количество " & _
            "FROM [Адресная программа$" & objCurRegion.Address(False, False) & "] " & _
            "WHERE NOT Наименование IS NULL ORDER BY Наименование, Ячейки" _
        )
    
    Do Until objRecordSet1.EOF
        Debug.Print objRecordSet1.Fields.Item("Наименование").Value
        
        With objRecordSet2
            .Filter = "Наименование='" & objRecordSet1.Fields.Item("Наименование").Value & "'"
            
            Do Until .EOF
                With .Fields
                    Debug.Print vbTab, .Item("Ячейки").Value, vbTab, .Item("Количество").Value
                End With
                
                .MoveNext
            Loop
        End With
        
        objRecordSet1.MoveNext
    Loop
    
    Set objCurRegion = Nothing
    
    objRecordSet2.Close
    objRecordSet1.Close
    
    objConnection.Close
    
    Set objRecordSet2 = Nothing
    Set objRecordSet1 = Nothing
    
    Set objConnection = Nothing
End Sub

Необходимые условия: Рабочая книга должна быть сохранена (обращение идёт именно к файлу Рабочей книги, а не к открытой в Excel Рабочей книге, не к текущим и не сохранённым изменениям); столбец «Ячейки» должен быть заполнен значениями (т.е., не как в первом выложенном Вами варианте).

В коде присутствует жёсткая привязка к адресу — «B2», откуда берётся текущий диапазон для извлечения. Первый запрос («objRecordSet1») извлекает все уникальные Наименования, второй («objRecordSet2») — весь диапазон целиком. Затем происходит вывод второго запроса с группировкой строк по строкам первого запроса. Для упрощения понимания вывод делается в окно отладки («Ctrl-G»), без формирования вывода в ячейки.

[dyshes90]

Iska, спасибо!!! Пример в студию please)

[Iska]

dyshes90, дык, на Вашем же файле делал. Только дозаполнил по паре отсутствующих значений в столбцах «Ячейки» и «Количество»: Копия pickpack1 (2).7z.

На всякий случай повторюсь: вывод идёт в окно отладки «Immediate», нажмите «Alt-F11», затем «Ctrl-G».