Преобразование базы данных

[andreysuperman42]

Всем здравствуйте.
Помогите преобразовать горизонтальную базу данных в вертикальную для последующей фильтрации по цене.
Желательно через форму.
Excel 2003.

[doober]

Так должно работать?

[andreysuperman42]

Использовал код doober, многое пока еще не понятно. Буду разбираться, как теперь отфильтровать по цене.
Спасибо еще раз.

[AleksandrH]

andreysuperman42 а что значит

Желательно через форму

.?
почему не воспользоваться кодом doober и вывести на второй лист, например, создать вручную новый "Лист2"?

Sub smth()
    Set DictObject = CreateObject("scripting.dictionary")
    Set shtActiveSheet = Sheets("Лист1")
    Set shtDestination = Sheets("Лист2")
    lngFinalRow = shtActiveSheet.Cells(shtActiveSheet.Rows.Count, 1).End(xlUp).Row    ' Находим последнюю строку
    lngFinalColumn = shtActiveSheet.Range("iv1").End(xlToLeft).Column    ' Находим последний столбец
    myArray = shtActiveSheet.Range(Cells(1, 1), Cells(lngFinalRow, lngFinalColumn))    ' Создаем массив
    
    For lngCounterArray = 2 To UBound(myArray)
        Дата = myArray(lngCounterArray, 1)
        Организация = myArray(lngCounterArray, 2)
        For lngCounterColumns = 3 To lngFinalColumn Step 3
            Товар = shtActiveSheet.Cells(lngCounterArray, lngCounterColumns)
            If Товар <> "" Then
                колво = shtActiveSheet.Cells(lngCounterArray, lngCounterColumns + 1)
                Цена = shtActiveSheet.Cells(lngCounterArray, lngCounterColumns + 2)
                Key = Дата & "|" & Организация & "|" & Товар & "|" & Цена
                If DictObject.Exists(Key) Then
                    DictObject.Item(Key) = DictObject.Item(Key) + колво
                Else
                    DictObject.Item(Key) = колво
                End If
            End If
        Next lngCounterColumns
    Next lngCounterArray
    Keys = DictObject.Keys
    ReDim Result(4, UBound(Keys))
    shtDestination.Cells.ClearContents
    For lngCounterArray = 0 To UBound(Keys)
        Key = Keys(lngCounterArray)
        Z = Split(Key, "|")
        колво = DictObject.Item(Key)
        shtDestination.Cells(lngCounterArray + 1, 1) = Z(0)
        shtDestination.Cells(lngCounterArray + 1, 2) = Z(1)
        shtDestination.Cells(lngCounterArray + 1, 3) = Z(2)
        shtDestination.Cells(lngCounterArray + 1, 4) = колво
        shtDestination.Cells(lngCounterArray + 1, 5) = Z(3)
    Next
End Sub

[andreysuperman42]

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

lngFinalRow = shtActiveSheet.Cells(shtActiveSheet.Rows.Count, 1).End(xlUp).Row

Вставил:

       lngFinalRow = shtActiveSheet.UsedRange.Rows.Count

По поводу сообщения AleksandrH, не совсем понял, зачем мне создавать еще один лист? Это же влияет на скорость работы (база не маленькая). Ведь все и так работает неплохо.

[AleksandrH]

А как Вы здесь сортируете?

[andreysuperman42]

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

[AleksandrH]

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

[andreysuperman42]

С сортировкой разобрался, а вот как отфильтровать список по цене (взял, к примеру по "10"), не выходит. Не убираются пустые строки.

Файл прилагаю.

[AleksandrH]

Private Sub UserForm_Initialize()

    Set DictObject = CreateObject("scripting.dictionary")
    Set shtActiveSheet = Sheets("Лист1")
    lngFinalRow = shtActiveSheet.UsedRange.Rows.Count    ' Находим последнюю строку
    lngFinalColumn = shtActiveSheet.Range("iv1").End(xlToLeft).Column    ' Находим последний столбец
    myArray = shtActiveSheet.Range(Cells(1, 1), Cells(lngFinalRow, lngFinalColumn))    ' Создаем массив
    For lngCounterArray = 2 To UBound(myArray)
        Дата = myArray(lngCounterArray, 1)
        Организация = myArray(lngCounterArray, 2)
        For lngCounterColumns = 3 To lngFinalColumn Step 3
            Товар = shtActiveSheet.Cells(lngCounterArray, lngCounterColumns)
            Цена = shtActiveSheet.Cells(lngCounterArray, lngCounterColumns + 2) '<------
            If Товар <> "" And Цена = 10 Then '<------
                Колво = shtActiveSheet.Cells(lngCounterArray, lngCounterColumns + 1)
                'Цена = shtActiveSheet.Cells(lngCounterArray, lngCounterColumns + 2) '<------
                Key = Дата & "|" & Организация & "|" & Товар & "|" & Цена
                If DictObject.Exists(Key) Then
                    DictObject.Item(Key) = DictObject.Item(Key) + Колво
                Else
                    DictObject.Item(Key) = Колво
                End If
            End If
        Next lngCounterColumns
    Next lngCounterArray
    Keys = DictObject.Keys
    ReDim Result(4, UBound(Keys))
    For lngCounterArray = 0 To UBound(Keys)
        Key = Keys(lngCounterArray)
        Z = Split(Key, "|")
        If Z(3) = 10 Then
            Колво = DictObject.Item(Key)
            Result(0, lngCounterArray) = Z(0)
            Result(1, lngCounterArray) = Z(1)
            Result(2, lngCounterArray) = Z(2)
            Result(3, lngCounterArray) = Колво
            Result(4, lngCounterArray) = Z(3)
        Else
            DictObject.Remove (Key)    ' НЕ УДАЛЯЕТ ПУСТУЮ СТРОКУ
        End If
    Next
    UserForm1.ListBox1.Column() = Result
End Sub