Arranging single column based on Datas in two different coulms as subheadings(Formula)

[toucharya]

Hi All,

I have data in column a and Column B such as
Column-a|Column-B
Asset| Owner
j Tom
k Harry
l Tom
m Jim
n Tom
o Jim

I want to build column D out of this data Like below:>>>

Column-D

Tom
j
l
n
Jim
m
o
Harry
K

Any help will be highly appreciated(Kindly Give a solution with Excel Formula)

Thanks,
Arya

 

[hiker95]

toucharya,

Welcome to the MrExcel forum.

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?


How about a macro solution?

I assume that your raw data is in Sheet1. If your raw data is in another worksheet, then what is the worksheet name?


Sample raw data in worksheet Sheet1 (before and after the macro):

Excel 2007
	A	B	C	D
1	Asset	Owner
2	j	Tom
3	k	Harry
4	l	Tom
5	m	Jim
6	n	Tom
7	o	Jim
8
9
10
Sheet1

After the macro:

Excel 2007
	A	B	C	D
1	Asset	Owner		Harry
2	j	Tom		k
3	k	Harry		Jim
4	l	Tom		m
5	m	Jim		o
6	n	Tom		Tom
7	o	Jim		j
8				l
9				n
10
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 06/18/2014, ME785271
Dim oa As Variant
Dim r As Long, lr As Long, n As Long, nr As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  oa = .Range(.Cells(2, 1), .Cells(lr, 2)).Value
  .Range(.Cells(2, 1), .Cells(lr, 2)).Sort key1:=.Range("B2"), order1:=1, key2:=.Range("A2"), order2:=1
  For r = 2 To lr
    n = Application.CountIf(.Columns(2), .Cells(r, 2).Value)
    nr = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
    If nr = 2 And .Cells(1, 4) = "" Then nr = 1
    .Cells(nr, 4) = .Cells(r, 2)
    nr = nr + 1
    .Cells(nr, 4).Resize(n).Value = .Range("A" & r & ":A" & r + n - 1).Value
    r = r + n - 1
  Next r
  .Range(.Cells(2, 1), .Cells(lr, 2)).Value = oa
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

 

[VBA Geek]

Sub autfilt()
Dim aItems As Variant
Dim lRow As Long
Dim oDic As Object
Dim vArr As Variant
Dim k    As Long
Dim varKey As Variant
Set oDic = CreateObject("Scripting.Dictionary")
lRow = Range("A1").CurrentRegion.Rows.Count
vArr = Range("A2:B" & lRow).Value
Range("D1").Value = "Owner"
With oDic
    .CompareMode = TextCompare
    For k = LBound(vArr, 1) To UBound(vArr, 1)
        If Not .Exists(vArr(k, 2)) Then
            .Add vArr(k, 2), vArr(k, 1)
        Else
            .Item(vArr(k, 2)) = .Item(vArr(k, 2)) & "," & vArr(k, 1)
        End If
    Next k
    For Each varKey In .Keys
        lRow = Range("D" & Rows.Count).End(xlUp).Offset(1).Row
        aItems = Split(.Item(varKey), ",")
        With Range("D" & lRow)
            .Value = varKey
            .Font.Bold = True
           .Offset(1).Resize(UBound(aItems) + 1).Value = Application.Transpose(aItems)
        End With
    Next varKey
End With
Set oDic = Nothing
End Sub

Hi All,

I have data in column a and Column B such as
Column-a|Column-B
Asset| Owner
j Tom
k Harry
l Tom
m Jim
n Tom
o Jim

I want to build column D out of this data Like below:>>>

Column-D

Tom
j
l
n
Jim
m
o
Harry
K

Any help will be highly appreciated(Kindly Give a solution with Excel Formula)

Thanks,
Arya

 

[hiker95]

toucharya,

Here is another macro that is faster than my first macro.

Sample raw data in worksheet Sheet1:

Excel 2007
	A	B	C	D
1	Asset	Owner
2	j	Tom
3	k	Harry
4	l	Tom
5	m	Jim
6	n	Tom
7	o	Jim
8
9
10
Sheet1

After the new macro using arrays in memory:

Excel 2007
	A	B	C	D
1	Asset	Owner		Tom
2	j	Tom		j
3	k	Harry		l
4	l	Tom		n
5	m	Jim		Harry
6	n	Tom		k
7	o	Jim		Jim
8				m
9				o
10
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below macro code, and, function.
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgDataV2()
' hiker95, 06/18/2014, ME785271
Dim a As Variant, o As Variant
Dim i As Long, ii As Long, j As Long
Dim x As Variant, k As Long
Dim lr As Long, nlr As Long, n As Long, sr As Long
Dim brng As Range
With Sheets("Sheet1")
  .Columns(4).ClearContents
  lr = .Cells(Rows.Count, 2).End(xlUp).Row
  a = .Range(.Cells(2, 1), .Cells(lr, 2))
  nlr = CountUnique(.Range("B2:B" & lr))
  ReDim o(1 To (lr - 1) + nlr, 1 To 1)
  ReDim x(1 To nlr)
  For i = 1 To UBound(a, 1)
    On Error Resume Next
    n = WorksheetFunction.Match(a(i, 2), x, 0)
    If Err.Number <> 0 Then   '***there was no match***
      k = k + 1
      x(k) = a(i, 2)
    End If
    On Error GoTo 0
  Next i
  For i = 1 To k
    n = Application.CountIf(Columns(2), x(i))
    If n = 1 Then
      Set brng = .Range("B1:B" & lr).Find(x(i), LookAt:=xlWhole)
      If Not brng Is Nothing Then
        ii = ii + 1
        o(ii, 1) = x(i)
        ii = ii + 1
        o(ii, 1) = .Cells(brng.Row, 1)
        Set brng = Nothing
      End If
    ElseIf n > 1 Then
      sr = 1
      For j = 1 To n
        Set brng = .Range("B" & sr & ":B" & lr).Find(x(i), LookAt:=xlWhole)
        If Not brng Is Nothing Then
          If sr = 1 Then
            ii = ii + 1
            o(ii, 1) = .Cells(brng.Row, 2).Value
            ii = ii + 1
            o(ii, 1) = .Cells(brng.Row, 1).Value
            sr = brng.Row
            Set brng = Nothing
          Else
            ii = ii + 1
            o(ii, 1) = .Cells(brng.Row, 1).Value
            sr = brng.Row
            Set brng = Nothing
          End If
        End If
      Next j
    End If
  Next i
  .Cells(1, 4).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(4).AutoFit
End With
End Sub
Function CountUnique(ByVal Rng As Range) As Long
'' Juan Pablo González, MrExcel MVP, 05/09/2003
'' http://www.mrexcel.com/forum/excel-questions/48385-need-count-unique-items-column-visual-basic-applications.html
Dim St As String
Set Rng = Intersect(Rng, Rng.Parent.UsedRange)
St = "'" & Rng.Parent.Name & "'!" & Rng.Address(False, False)
CountUnique = Evaluate("SUM(IF(LEN(" & St & "),1/COUNTIF(" & St & "," & St & ")))")
End Function

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV2 macro (that also contains a function).

 

[hiker95]

Cross posted here:

Arranging single column based on Datas in two different coulms as subheadings(Formula)

A message to forum cross posters
Please read this
Excelguru Help Site - A message to forum cross posters

 

[toucharya]

Great... It works a s expected

Sub autfilt()
Dim aItems As Variant
Dim lRow As Long
Dim oDic As Object
Dim vArr As Variant
Dim k    As Long
Dim varKey As Variant
Set oDic = CreateObject("Scripting.Dictionary")
lRow = Range("A1").CurrentRegion.Rows.Count
vArr = Range("A2:B" & lRow).Value
Range("D1").Value = "Owner"
With oDic
    .CompareMode = TextCompare
    For k = LBound(vArr, 1) To UBound(vArr, 1)
        If Not .Exists(vArr(k, 2)) Then
            .Add vArr(k, 2), vArr(k, 1)
        Else
            .Item(vArr(k, 2)) = .Item(vArr(k, 2)) & "," & vArr(k, 1)
        End If
    Next k
    For Each varKey In .Keys
        lRow = Range("D" & Rows.Count).End(xlUp).Offset(1).Row
        aItems = Split(.Item(varKey), ",")
        With Range("D" & lRow)
            .Value = varKey
            .Font.Bold = True
           .Offset(1).Resize(UBound(aItems) + 1).Value = Application.Transpose(aItems)
        End With
    Next varKey
End With
Set oDic = Nothing
End Sub

 

[toucharya]

Thanks a lot for trying it out and really an useful input for me.... But will it be possible through Formulae???

 

[hiker95]

toucharya,

Did you even try my macro in reply #4?????