Значения в столбце2 развернуть (транспонировать) в строку по столбцам Excel с условием из столбца1

Question

В столбце1 есть повторяющиеся значения. В столбце2 есть другие значения. Необходимо для повторяющихся значений в столбце1 развернуть по столбцам соответствующие значения из столбца2. Прикладываю скрин (там понятнее, чем словами).

Написал нечто -)), но работает весьма коряво.. Считай не работает!

    Sub EqualValFromRowToColumn2()
    
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
        
        Dim rng As Range, wb As Workbook
        Dim Lastrow As Long
        Set wb = ActiveWorkbook
        
        Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
                
        Set rng = Range([a1], Range("a" & Rows.Count).End(xlUp))
                
        For i = 1 To Lastrow
            If Cells(i + 1, 1).Value = Cells(i, 1) Then
                Cells(i + 1, 3).Value = 1
            ElseIf Cells(i + 1, 1).Value <> Cells(i, 1) Then
                Cells(i + 1, 3).Value = 0
            End If
        Next i
        
        For j = 1 To Lastrow
            If Cells(j, 3).Value = 1 Then
                Cells(j, 4).Value = Cells(j, 3).Value + Cells(j - 1, 4).Value
            ElseIf Cells(j, 3).Value = 0 Then
                Cells(j, 4).Value = Cells(j, 3).Value
            End If
        Next j
        
        For k = 1 To Lastrow
            If Cells(k + 1, 1).Value = Cells(k, 1) Then
                Cells(k + 1, 5).Value = Cells(k, 2).Value & ";" & Cells(k + 1, 2).Value & ";" & Cells(k + 2, 2).Value & ";" & Cells(k + 3, 2).Value & ";" & Cells(k + 4, 2).Value & ";" & Cells(k + 5, 2).Value
            End If
        Next k
        
    .ScreenUpdating = True
    .EnableEvents = True
    
    End With
    
End Sub

Подскажите в чём могла собака порыться?

Answer 1

Добавьте перед данными первую пустую строку

Function fMax(sht As Worksheet, lRow As Long) As Long
    With Application
        fMax = .Max(.CountIf(sht.Range("A1:A" & lRow), sht.Range("A1:A" & lRow)))
    End With
End Function

Sub EqualValFromRowToColumn2()
    Dim aData()
    Dim i As Long, n As Long, j As Long
          
    With Worksheets("Sheet1")
        i = .Cells(.Rows.Count, 1).End(xlUp).Row
        aData = .Range("A1:B" & i).Value
    End With

    ReDim Preserve aData(1 To UBound(aData), 1 To fMax(Worksheets("Sheet1"), i) + 2)
    
    For i = 2 To UBound(aData)
        If aData(i, 1) <> aData(i - 1, 1) Then
            j = 2
        
            For n = i To UBound(aData)
                If aData(i, 1) = aData(n, 1) Then
                    j = j + 1: aData(i, j) = aData(n, 2)
                Else: Exit For
                End If
            Next n
        End If
    Next i
    
    With Application: .ScreenUpdating = False: .EnableEvents = False: End With
    Worksheets("Sheet1").Range("H1").Resize(UBound(aData), UBound(aData, 2)).Value = aData
    With Application: .ScreenUpdating = True: .EnableEvents = True: End With
End Sub

Если не используются события листа, .EnableEvents отключать не нужно. Да и отключение обновления экрана (.ScreenUpdating) при разовой вставке на лист мало чем поможет.

БЛОГ НА HUSL

Значения в столбце2 развернуть (транспонировать) в строку по столбцам Excel с условием из столбца1

Ответы (1 шт):