Страницы: 1
RSS
Свод данных из нескольких столбцов в один друг под другом при наличии пустых столбцов
 
Добрый день!

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

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

Пример задачи и решения приложила, порядок сбора данных в столбец значение не имеет.
Есть ли возможность решить эту задачу?

Заранее благодарю всех откликнувшихся!
 
Выделите ячейки, запустите макрос.
Код
Sub ToOneColumn()
    Dim r As Range
    On Error Resume Next
        Set r = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    
    If Not r Is Nothing Then
        Dim c As Range
        Dim brr As Variant
        brr = r.Areas(1)
        
        If IsArray(brr) Then
            Dim arr As Variant
            ReDim arr(1 To Rows.Count, 1 To 1)
            Dim u As Long
            Dim y As Long
            Dim x As Integer
            
            For x = 1 To UBound(brr, 2)
            For y = 1 To UBound(brr, 1)
                If Not IsEmpty(brr(y, x)) Then
                    u = u + 1
                    If u > UBound(arr, 1) Then Exit For
                    arr(u, 1) = brr(y, x)
                End If
            Next
            Next
            If u > 0 Then
                With Workbooks.Add(1)
                    .Sheets(1).Cells(1, 1).Resize(u, 1) = arr
                    .Saved = True
                End With
            End If
        End If
    End If
End Sub
 
МатросНаЗебре, спасибо Вам огромное! Результат превосходный!
Могли бы ещё подсказать из-за чего может выходить ошибка с отсылкой на эту часть макроса:
     
Код
 .Sheets(1).Cells(1, 1).Resize(u, 1) = arr
 
Как вариант, данных больше, чем 1048576 строк на листе. На этот случай макрос примет вид.
Код
Sub ToOneColumn()
    Dim r As Range
    On Error Resume Next
        Set r = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
     
    If Not r Is Nothing Then
        Dim c As Range
        Dim brr As Variant
        brr = r.Areas(1)
         
        If IsArray(brr) Then
            Dim arr As Variant
            ReDim arr(1 To Rows.Count, 1 To 1)
            Dim u As Long
            Dim y As Long
            Dim x As Integer
             
            For x = 1 To UBound(brr, 2)
            For y = 1 To UBound(brr, 1)
                If Not IsEmpty(brr(y, x)) Then
                    u = u + 1
                    If u > UBound(arr, 1) Then Exit For
                    arr(u, 1) = brr(y, x)
                End If
            Next
            Next
            If u > r.Parent.Rows.Count Then
                MsgBox "Влезло не всё.", vbInformation
            Else
                If u > 0 Then
                    With Workbooks.Add(1)
                        .Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), 1) = arr
                        .Saved = True
                    End With
                End If
            End If
        End If
    End If
End Sub
 
pq
Код
let
    Source = Excel.Workbook(Web.Contents("https://www.planetaexcel.ru/bitrix/components/bitrix/forum.interface/show_file.php?fid=437821&action=download")){[Item="Исходные данные",Kind="Sheet"]}[Data],
    a = Table.UnpivotOtherColumns(Source, {}, "w", "q")[q],
    b = List.Sort(a, Order.Ascending)
in
    b
Страницы: 1
Наверх