Страницы: 1
RSS
Перенос значений в таблице(типа транспонирования)
 
Друзья, подскажите пожалуйста. Какой формулой или функционалом экселя можно привести таблицу к следующему виду(в файле.) В таблице 50к строк.
 
Наверное можно и формулой, но для 50к строк лучше что нибудь типа макроса или PQ
Согласие есть продукт при полном непротивлении сторон
 
Можно и макросом, только как правильно написать цикл?
 
А пустые строки в итоговом выводе тоже надо оставлять? Или это для наглядности и их можно удалить?
Вот горшок пустой, он предмет простой...
 
Код
Sub Transform()
  Dim a, r&, r1&, re
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = "\d+:"
  a = Range(Cells(2), Cells(Rows.Count, 1).End(xlUp)): r = 1
  Do While Not re.test(a(r, 1))
    a(r, 1) = Empty: r = r + 1
  Loop
  re.Pattern = "\d+_\d+": r1 = r
  For r = r + 1 To UBound(a)
    If re.test(a(r, 1)) Then
      a(r1, 2) = IIf(IsEmpty(a(r1, 2)), "", a(r1, 2) & ", ") & a(r, 1)
      a(r, 1) = Empty
    Else
      r1 = r
    End If
  Next
  Cells(1, 3).Resize(UBound(a), 2) = a
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Еще вариант:
Код
Option Explicit
Sub convertFormat()
    Dim selectRn As Range, i As Long, x As Integer, lastCurRowFound As Boolean
    
    ' Диапазон для анализа (с ячейки A3 до A_последняяЗаполенная)
    With ActiveSheet
        Set selectRn = Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    
    With selectRn
        ' Идем по диапазону
        For i = 1 To selectRn.Rows.Count
            ' Маркер строк, которые нужно не трогать - наличие нижнего подчеркивания
            ' В этих строках начинаем смотреть вниз по диапазону - пока не встретим еще одну строку без нижнего
            '   подчеркивания или не дойдем до конца диапазона
            If selectRn.Cells(i, 1).Value Like "*_*" = False Then
                ' Смещение от ячейки с "датой"
                x = 1
                
                ' TRUE когда ячейка является "датой" или достигнут конец диапазона - выход из цикла
                lastCurRowFound = False
                
                ' Шагаем вниз от строки с датой, пока не найдем строку с _ или не дойдем до конца диапазона
                Do
                    '   Выделить текущую просматриваемую ячейку
                    '   selectRn.Cells(i + x, 1).Select
                    
                    ' Строка с _ найдена или диапазон закончился
                    If selectRn.Cells(i + x, 1).Value Like "*_*" = False Or IsEmpty(selectRn.Cells(x, 1)) Then
                        ' Возвращаем объединенные ячейки от первой просматриваемой до отстоящией от нее на x-1 строк
                        ' см. rangeStringJoin() ниже
                        selectRn.Cells(i, 1).Offset(0, 1).Value = rangeStringJoin(selectRn.Cells(i + 1, 1).Resize(Rowsize:=x - 1), ", ")
                        
                        ' Следующая строка с "датой" начнется не раньше, чем закончатся объединяемые ячейки, т.е. x-1 строк смотреть не нужно, пропускаем
                        i = i + x - 1
                        ' Выходим из цикла
                        lastCurRowFound = True
                    Else
                        ' Текущая ячейка не содержит "дату" и не последняя, повторим цикл, опустившись на строчку
                        x = x + 1
                    End If
                Loop While x < selectRn.Rows.Count And lastCurRowFound <> True
            End If
        Next i
        
    End With
End Sub

' Объедиение значений из ячеек
' rn - диапазон объедиения
' delimetr - разделитель значений
Function rangeStringJoin(rn As Range, delimetr As String) As String
    Dim txt As String, i As Long
    txt = ""
    ' Для каждой ячейки из диапазона
    For i = 1 To rn.Cells.Count
        ' Текст = текст + значение текущей ячейки + разделитель если строка - не последняя
        txt = txt & rn.Cells(i).Value & IIf(i < rn.Cells.Count, delimetr, "")
    Next i
    ' Возвращаем значение функции
    rangeStringJoin = txt
End Function

In GoTo we trust
 
Вариант на Power Query:

Код
let
    Source = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    AddedMark = Table.AddColumn(Source, "Признак", each if Text.Contains([Как есть], ":") then [Как есть] else null, type text),
    FilledDown = Table.FillDown(AddedMark,{"Признак"}),
    GroupedRows = Table.Group(FilledDown, {"Признак"}, {{"Как надо", each Text.Combine( Table.Skip(_,1)[Как есть], ", " ), type text}})
in
    GroupedRows
Вот горшок пустой, он предмет простой...
 
Ну и мой до кучи
Код
Sub Riddle()
arr = Range("A3:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim arrNew(1 To UBound(arr), 1 To 2)
For I = 1 To UBound(arr) - 1
    If Len(arr(I, 1)) - Len(Replace(arr(I, 1), ":", "")) = 3 Then
        N = N + 1
        arrNew(N, 1) = arr(I, 1)
        arrNew(N, 2) = arr(I + 1, 1)
    Else
        arrNew(N, 2) = arrNew(N, 2) & "," & arr(I + 1, 1)
    End If
Next
Range("E3").Resize(N, 2) = arrNew
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Ігор Гончаренко, PooHkrd, Sanja, tolstak, ребята, вы просто огонь! Все работает, спасибо вам огромное!
Посмотрите пожалуйста еще вот такую задачку, она аналогична первой, только немного другая
Изменено: Exellent - 12.07.2019 21:41:37
 
Код
Sub Riddle_1()
arr = Range("A5:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value
ReDim arrNew(1 To UBound(arr), 1 To 2)
For I = 1 To UBound(arr) - 1
    If arr(I, 1) <> "" Then
        N = N + 1
        arrNew(N, 1) = arr(I, 1)
    End If
    If arr(I + 1, 2) <> "" Then
        arrNew(N, 2) = IIf(arrNew(N, 2) <> "", arrNew(N, 2) & ", " & arr(I + 1, 2), arr(I + 1, 2))
    End If
Next
Range("G5").Resize(N, 2) = arrNew
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Sanja,
Сработало, спасибо!

Всем откликнувшимся огромнейшая благодарность, вы крутые!!
Тему можно закрывать.  
Страницы: 1
Наверх