[Solved] Rearranging Excel Cell based on Value [closed]

by


This sub procedure works with two variant arrays.

Option Explicit

Sub Macro3()
    Dim i As Long, j As Long, nr As Long
    Dim tmp As Variant, arr As Variant, hdr As Variant, vals As Variant

    With Worksheets("sheet4")
        tmp = .Cells(1, "A").CurrentRegion
        ReDim vals(LBound(tmp, 1) To UBound(tmp, 1), LBound(tmp, 2) To UBound(tmp, 2))
        nr = UBound(tmp, 1) + 2

        For i = LBound(tmp, 1) To UBound(tmp, 1)
            vals(i, 1) = tmp(i, 1)
            For j = LBound(tmp, 2) + 1 To UBound(tmp, 2)
                If CBool(InStr(1, tmp(i, j), Chr(58), vbBinaryCompare)) Then
                    arr = Split(tmp(i, j), Chr(58))
                    arr(0) = Trim(arr(0)): arr(1) = Trim(arr(1))
                    hdr = Application.Match(arr(0), .Rows(nr), 0)
                    If IsError(hdr) Then
                        hdr = .Cells(nr, .Columns.Count).End(xlToLeft).Offset(0, 1).Column
                        .Cells(nr, hdr) = arr(0)
                        If UBound(vals, 2) < hdr Then
                            ReDim Preserve vals(LBound(tmp, 1) To UBound(tmp, 1), LBound(tmp, 2) To hdr)
                        End If
                    End If
                    vals(i, hdr) = arr(1)
                End If
            Next j
        Next i

        .Cells(nr + 1, "A").Resize(UBound(vals, 1), UBound(vals, 2)) = vals
    End With

End Sub

enter image description here

1

solved Rearranging Excel Cell based on Value [closed]