Extract text from one row to unique row

[dragonlwc]

What I want to do is to extract data from one row and copy it to unique row
What function can be used so that the result like below one

Before

Name	Subject	Grade
Tom	Math	A
Mary	Eng	C
Peter	Phy	D
Mary	Chem	B
Tom	Bio	B
John	Math	C

<colgroup><col width="64" span="3" style="width:48pt"> </colgroup><tbody>
</tbody>

After

Name	Subject	Grade
Tom	Math	A	Bio	B
Mary	Eng	C	Chem	B
Peter	Phy	D
John	Math	C

<colgroup><col width="64" span="5" style="width:48pt"> </colgroup><tbody>
</tbody>

 

[MickG]

Try this for Results on sheet 2.

[COLOR="Navy"]Sub[/COLOR] MG16May09
[COLOR="Navy"]Dim[/COLOR] RAY [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
RAY = ActiveSheet.Range("A1").CurrentRegion.Resize(, 3)
ReDim nray(1 To UBound(RAY, 1), 1 To 3)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(RAY, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(RAY(n, 1)) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        nray(c, 1) = RAY(n, 1)
        nray(c, 2) = RAY(n, 2)
        nray(c, 3) = RAY(n, 3)
        Dic.Add RAY(n, 1), Array(c, 3)
[COLOR="Navy"]Else[/COLOR]
    Q = Dic.Item(RAY(n, 1))
         Q(1) = Q(1) + 2
         [COLOR="Navy"]If[/COLOR] UBound(nray, 2) <= Q(1) [COLOR="Navy"]Then[/COLOR] ReDim Preserve nray(1 To UBound(RAY, 1), 1 To Q(1))
         nray(Q(0), Q(1) - 1) = RAY(n, 2)
         nray(Q(0), Q(1)) = RAY(n, 3)
         nray(1, Q(1) - 1) = "Subject"
         nray(1, Q(1)) = "Grade"
         oMax = Application.Max(oMax, Q(1))
    Dic.Item(RAY(n, 1)) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
Sheets("Sheet2").Range("A1").Resize(c, oMax) = nray

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[dragonlwc]

you are genius~~~
Thank you so much, learn a lots from the code

 

[walruseggman]

Bummer, posted my solution before I was alerted that this was a cross post.

Extract text from one row and copy to unique row

Oh well, here's my attempt:

<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit;">Sub chau()
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets.Add(, Sheets(Sheets.Count))
ws1.Columns(1).AdvancedFilter xlFilterCopy, , ws2.[A1], True
With ws1.Columns(1)
For Each n In ws2.Columns(1).SpecialCells(2)
c = 2
Set d = .Find(n.Value)
f = d.Address
Do
d.Offset(0, 1).Resize(1, 2).Copy ws2.Cells(n.Row, c)
c = c + 2
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> f
Next
End With
End Sub</code>

 

[pgc01]

Hi dragonlwc
Welcome to the board

Cross-post???

That's really rude. You won't get many friends like this.

 

[dragonlwc]

Hi dragonlwc
Welcome to the board

Cross-post???

That's really rude. You won't get many friends like this.

I am new, why cross-post is rude?
sorry if I get sth wrong

 

[Michael M]

@dragonlwc
If you have cross posted, you need to read here, then you will understand the comment from pgc

Excelguru Help Site - A message to forum cross posters