Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Преобразовать горизонтальную таблицу в вертикальную
 
#1
10.01.2019 13:57:02
Приветствую Форумчане и Хозяева Сайта!
С прошедшими праздниками всех!

Есть следующая задача:
Продажи в рублях, по дням, несколько десятков номенклатуры по нескольким городам за год.
Таблица получается большая. Она в горизонтальном виде. Её нужно преобразовать в вертикальный. В виде базы данных.
Во вложении пример.

Буду очень благодарен за решение без макросов и надстроек.
 
 
 
#2
10.01.2019 14:06:49
Цитата
vlad_d написал: без макросов и надстроек.
Примените макрос ОДИН раз из ЭТОГО приема
Изменено: Sanja - 10.01.2019 14:07:27
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
10.01.2019 15:07:43
vlad_d,

Поскольку начиная с Excel 2016 Power Query уже не надстройка, то вот  :) :
Код
let
    Source = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {"№", "Город", "Номенклатура", "ИТОГО"}, "Дата", "Рубли"),
    #"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"ИТОГО"}),
    #"Changed Type" = Table.TransformColumnTypes(#"Removed Columns",{{"Дата", type date}, {"Рубли", type number}, {"№", Int64.Type}, {"Город", type text}, {"Номенклатура", type text}})
in
    #"Changed Type"
 
 
 
#4
10.01.2019 18:38:48
Вариант формулами
 
 
 
#5
11.01.2019 06:33:06
Sanja, благодарю Вас!
Способ работает. Сохраню себе макрос.

Aleksei_Zhigulin, спасибо за ответ!
Я "чайник" в Power Query). Сходу не разобрался, как это сделать... Проверю на работоспособность чуть позже.

jakim , и Вам благодарность!!!
Это уже ближе и более понятнее. Быстрее смогу вникнуть.

Если еще будут варианты с удовольствием приму их!
 
 
 
#6
06.09.2021 13:47:20
Добрый день!
У меня похожая задача, но не пойму как применить данные методы, помогите пожалуйста
 
 
 
#7
06.09.2021 14:41:28
Виктор, здравствуйте
Метод .IndentLevel (например Range("A1").IndentLevel или Cells(1,1).IndentLevel) вернёт уровень отступов в ячейке — по ним (отступам), вы и сможете создать классическую плоскую структуру — вот вам набор инструментов  ;)
Изменено: Jack Famous - 06.09.2021 14:42:27
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#8
06.09.2021 15:18:42
Код
Option Explicit

Sub ВертикальнуюВгоризонтальную()
    Dim sh As Worksheet
    Set sh = Sheets(1)
    
    Dim y As Long
    Dim arrA As Variant
    Dim arr2 As Variant
    With sh
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arrA = .Range(.Cells(1, 1), .Cells(y, 1))
        y = .Cells(2, .Columns.Count).End(xlToLeft).Column
        arr2 = .Range(.Cells(2, 1), .Cells(3, y))
    End With
    
    Dim cl As Range
    Dim rn As Range
    On Error Resume Next
        Set rn = sh.UsedRange.Offset(4, 7).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If Not rn Is Nothing Then
        Dim arrO As Variant
        ReDim arrO(1 To rn.Cells.Count, 1 To 7)
        
        Dim u As Long
        Dim x As Integer
        u = 0
        For Each cl In rn
            With cl
                If Not IsEmpty(.Value) Then
                    u = u + 1
                    For y = .Row To 1 Step -1
                        Select Case sh.Cells(y, 1).IndentLevel
                        Case 0
                            arrO(u, 1) = arrA(y, 1)
                            Exit For
                        Case 2
                            arrO(u, 2) = arrA(y, 1)
                        Case 6
                            arrO(u, 3) = arrA(y, 1)
                        Case 8
                            If IsEmpty(arrO(u, 4)) Then
                                arrO(u, 4) = arrA(y, 1)
                            End If
                        End Select
                    Next
                    arrO(u, 5) = arr2(1, .Column)
                    arrO(u, 6) = arr2(2, .Column)
                    arrO(u, 7) = .Value
                    
                End If
            End With
        Next
        Sheets(2).Cells(1, 1).Resize(UBound(arrO, 1), UBound(arrO, 2)) = arrO
    End If
    
End Sub
Если, конечно, не отвергать макросы.
 
 
 
#9
07.09.2021 17:18:35
Как работать с этим макросом
 
 
 
#10
07.09.2021 17:25:26
Создание макросов и пользовательских функций на VBA (planetaexcel.ru)
Способа 1, в принципе, достаточно.

Вставьте код в стандартный модуль из сообщения #8.
Запустите макрос, Alt+F8 Выполнить.
Результат будет на втором листе.
 
 
 
#11
08.09.2021 13:07:52
Не получается выходит ошибка, я думал что то из-за не формата выгрузки из 1С (добавляются пустые столбцы), но нет все равно выходит одна и та же ошибка
 
 
 
#12
08.09.2021 13:11:12
Попробовал запускать из файла с поддержкой макросов, вставлял в отдельный модуль все равно ошибка
 
 
 
#13
08.09.2021 14:03:03
Кликните Debug.
И выложите скриншот, где код остановился.
 
 
 
#14
08.09.2021 16:59:41
Вот где остановился
 
 
 
#15
08.09.2021 17:18:22
Файл отличается от файла из примера.
Добавьте второй лист.
 
 
 
#16
08.09.2021 17:21:31
:)
Цитата
vlad_d написал: Буду очень благодарен за решение без макросов
Цитата
vlad_d написал:  Sanja , благодарю Вас! Способ работает. Сохраню себе макрос.
Изменено: vikttur - 08.09.2021 17:21:51
 
 
 
#17
08.09.2021 17:27:03
Offtopic: видимо, пришлось сохранить макрос без благодарности - с отвращением :)
 
 
 
#18
09.09.2021 10:18:34
Цитата
МатросНаЗебре написал: Файл отличается от файла из примера.
Не загружается - большой размер
Отправил на почту
 
 
 
#19
09.09.2021 10:27:00
Цитата
МатросНаЗебре написал:
Файл отличается от файла из примера.Добавьте второй лист.
Вот ссылка https://docs.google.com/spreadsheets/d/13EMyDv0AsOHHOqozTXZXzsd5ohC1Yv7b/edit?usp=sharing&ou...
 
 
 
#20
09.09.2021 10:27:20
МатросНаЗебре просил Вас отправлять на почту?
Пример - небольшая демонстрация вопроса, а не рабочий файл.
 
 
 
#21
09.09.2021 11:07:13
Поправил на случай, если нет второго листа.
Код
Option Explicit
 
Sub ВертикальнуюВгоризонтальную()
    Dim sh As Worksheet
    Set sh = Sheets(1)
     
    Dim y As Long
    Dim arrA As Variant
    Dim arr2 As Variant
    With sh
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arrA = .Range(.Cells(1, 1), .Cells(y, 1))
        y = .Cells(2, .Columns.Count).End(xlToLeft).Column
        arr2 = .Range(.Cells(2, 1), .Cells(3, y))
    End With
     
    Dim cl As Range
    Dim rn As Range
    On Error Resume Next
        Set rn = sh.UsedRange.Offset(4, 7).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If Not rn Is Nothing Then
        Dim arrO As Variant
        ReDim arrO(1 To rn.Cells.Count, 1 To 7)
         
        Dim u As Long
        Dim x As Integer
        u = 0
        For Each cl In rn
            With cl
                If Not IsEmpty(.Value) Then
                    u = u + 1
                    For y = .Row To 1 Step -1
                        Select Case sh.Cells(y, 1).IndentLevel
                        Case 0
                            arrO(u, 1) = arrA(y, 1)
                            Exit For
                        Case 2
                            arrO(u, 2) = arrA(y, 1)
                        Case 6
                            arrO(u, 3) = arrA(y, 1)
                        Case 8
                            If IsEmpty(arrO(u, 4)) Then
                                arrO(u, 4) = arrA(y, 1)
                            End If
                        End Select
                    Next
                    arrO(u, 5) = arr2(1, .Column)
                    arrO(u, 6) = arr2(2, .Column)
                    arrO(u, 7) = .Value
                     
                End If
            End With
        Next
        
        If Sheets.Count < 2 Then Sheets.Add After:=Sheets(1)
        
        Sheets(2).Cells(1, 1).Resize(UBound(arrO, 1), UBound(arrO, 2)) = arrO
    End If
     
End Sub
 
 
 
#22
09.09.2021 11:15:03
...
Изменено: vikttur - 09.09.2021 22:34:41
 
 
 
#23
09.09.2021 14:11:38
Продолжаю гадать по скриншотам )
Код
Option Explicit
  
Sub ВертикальнуюВгоризонтальную()
    Dim sh As Worksheet
    Set sh = Sheets(1)
      
    Dim y As Long
    Dim arrA As Variant
    Dim arr2 As Variant
    With sh
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arrA = .Range(.Cells(1, 1), .Cells(y, 1))
        'y = .Cells(2, .Columns.Count).End(xlToLeft).Column
        y = .UsedRange.Column + .UsedRange.Columns.Count - 1
        arr2 = .Range(.Cells(2, 1), .Cells(3, y))
    End With
      
    Dim cl As Range
    Dim rn As Range
    On Error Resume Next
        Set rn = sh.UsedRange.Offset(4, 7).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If Not rn Is Nothing Then
        Dim arrO As Variant
        ReDim arrO(1 To rn.Cells.Count, 1 To 7)
          
        Dim u As Long
        Dim x As Integer
        u = 0
        For Each cl In rn
            With cl
                If Not IsEmpty(.Value) Then
                    u = u + 1
                    For y = .Row To 1 Step -1
                        Select Case sh.Cells(y, 1).IndentLevel
                        Case 0
                            arrO(u, 1) = arrA(y, 1)
                            Exit For
                        Case 2
                            arrO(u, 2) = arrA(y, 1)
                        Case 6
                            arrO(u, 3) = arrA(y, 1)
                        Case 8
                            If IsEmpty(arrO(u, 4)) Then
                                arrO(u, 4) = arrA(y, 1)
                            End If
                        End Select
                    Next
                    arrO(u, 5) = arr2(1, .Column)
                    arrO(u, 6) = arr2(2, .Column)
                    arrO(u, 7) = .Value
                      
                End If
            End With
        Next
         
        If Sheets.Count < 2 Then Sheets.Add After:=Sheets(1)
         
        Sheets(2).Cells(1, 1).Resize(UBound(arrO, 1), UBound(arrO, 2)) = arrO
        Sheets(2).Select
    End If
End Sub
 
 
 
Страницы: 1
Наверх