Страницы: 1
RSS
VBA. Работа с таблицами. Из комбинационной в простую
 
Есть таблица, так называемого, сложного вида, как "пересобрать" ее макросом в простой на другом листе? Предполагается многократное использование макроса, т.о. итоговый лист должен подчищаться, перед новой "сборкой".
Количество столбцов и строк исходной таблицы (Лист1) не фиксированы, эталон на Лист2.
 
Редизайнер
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Шикарно, спасибо.
 
Код
Option Explicit

Sub Пересобрать()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    If Not IsEmpty(arr) Then
        Dim brr As Variant
        brr = GetBrr(arr)
        Erase arr
        If Not IsEmpty(brr) Then
            OutArr brr
        End If
    End If
End Sub

Sub OutArr(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(1, UBound(arr, 2))
                .Cells = Array("Страна", "Город", "Вид", "Продукт", "Дата", "Количество")
                .Font.Bold = True
            End With
            With .Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Cells = arr
                .EntireColumn.AutoFit
            End With
        End With
        .Saved = True
    End With
End Sub

Function GetBrr(arr As Variant) As Variant
    If UBound(arr, 1) > 1 Then
        If UBound(arr, 2) > 4 Then
            Dim brr As Variant
            ReDim brr(1 To (UBound(arr, 2) - 4) * (UBound(arr, 1) - 1), 1 To 6)
            
            Dim u As Long
            Dim y As Long
            Dim x As Integer
            Dim k As Integer
            For x = 5 To UBound(arr, 2)
                For y = 2 To UBound(arr, 1)
                    u = u + 1
                    For k = 1 To 4
                        brr(u, k) = arr(y, k)
                    Next
                    brr(u, 5) = arr(1, x)
                    brr(u, 6) = arr(y, x)
                Next
            Next
            GetBrr = brr
        End If
    End If
End Function

Function GetArr(sh As Worksheet) As Variant
    With sh
        Dim y As Long
        Dim x As Integer
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If y > 1 And x > 4 Then
            GetArr = .Range(.Cells(1, 1), .Cells(y, x))
        End If
    End With
End Function
Страницы: 1
Наверх