CODEWITHSUNDEEP
excelvba
phh
phh

Reputation: 149

Range of cell rows to column base on first row values in excel

I have range of cells in excel like 

A   A   A   B   B   B
A1  A2  A3  B1  B2  B3

Is there any idea how to convert this range of cell into -

A   B
A1  B1
A2  B2
A3  B3

I tried to do it with Kutools addon in excel but it can't solve my problem. I don't mind if I have to use VBA for this.

Upvotes: 1

Views: 92

Answers (2)

Vityata
Vityata

Reputation: 43575

Here is what I have managed to do, using dictionaries. I am using the following additional functions:

This one loops through the values in the first row and returns the unique ones as array. It will be the "title" of the list:

Public Function getUniqueElementsFromArray(elementsInput As Variant) As Variant

    Dim returnArray     As Variant
    Dim element         As Variant
    Dim tempDict        As Object
    Dim cnt             As Long

    Set tempDict = CreateObject("Scripting.Dictionary")

    For Each element In elementsInput
        tempDict(element) = 1
    Next element

    ReDim returnArray(tempDict.Count - 1)
    For cnt = 0 To tempDict.Count - 1
        returnArray(cnt) = tempDict.Keys()(cnt)
    Next cnt

    getUniqueElementsFromArray = returnArray

End Function

This one gets the lastRow of a given column:

Function lastRow(Optional strSheet As String, Optional colToCheck As Long = 1) As Long

    Dim shSheet  As Worksheet

    If strSheet = vbNullString Then
        Set shSheet = ActiveSheet
    Else
        Set shSheet = Worksheets(strSheet)
    End If

    lastRow = shSheet.Cells(shSheet.Rows.Count, colToCheck).End(xlUp).Row

End Function

This one takes a single row range and returns a 1D array:

Public Function getArrayFromHorizontRange(rngRange As Range) As Variant

    With Application
        getArrayFromHorizontRange = .Transpose(.Transpose(rngRange))
    End With

End Function

This is the main "engine":

Option Explicit

Public Sub TestMe()

    Dim keyValues       As Variant
    Dim keyElement      As Variant
    Dim keyElementCell  As Range
    Dim inputRange      As Range
    Dim outputRange     As Range
    Dim outputRangeRow  As Range
    Dim colNeeded       As Long

    Set inputRange = Range("A1:K2")
    Set outputRange = Range("A10")
    Set outputRangeRow = outputRange

    keyValues = getUniqueElementsFromArray(getArrayFromHorizontRange(inputRange.Rows(1)))

    For Each keyElement In keyValues
        Set outputRangeRow = Union(outputRangeRow, outputRange)
        outputRange.value = keyElement
        Set outputRange = outputRange.Offset(0, 1)
    Next keyElement

    For Each keyElementCell In inputRange.Rows(2).Cells
        colNeeded = WorksheetFunction.match(keyElementCell.Offset(-1), outputRangeRow, 0)
        Set outputRange = Cells(lastRow(colToCheck:=colNeeded) + 1, colNeeded)
        outputRange.value = keyElementCell
    Next keyElementCell

End Sub

And this is the input and the output: enter image description here

Upvotes: 1

Kresimir L.
Kresimir L.

Reputation: 2441

Use this formula in cell A7. Enter it with CTRL+SHIFT+ENTER combination, then drag below your table.

=IFERROR(INDEX($A$1:$F$2,2,SMALL(IF((A$6=$A$1:$F$1), COLUMN($A$1:$F$1)-MIN(COLUMN($A$1:$F$1))+1, ""),ROWS($A$1:A1))),"")

enter image description here

Upvotes: 2

Related Questions