Need Help for Rearranging Data with Macro or Formula

[culyus]

Hello All,

This might be very easy for some of you. I have a data sheet like below:

ID P1 P2 ... Pn
1 A
2 A B
3 B A .... C
.
.

So in each row there are different number of columns with values. Id like to arrange it into;

ID P Rank
1 A First
2 A First
2 B Last
3 B First
3 A 2
3 C Last

So the last column with a value will be labeled as last and the first as first and the rest with their ranks (relative column number to the first) or we can also say middle if it is easier to solve this way.

Many thanks for your help. If anything is not clear, Id love to explain more.


Cheers,

 

[MickG]

Try this:-
Results Start Sheet(2) "A1".

[COLOR="Navy"]Sub[/COLOR] MG22Nov26
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] AcRng       [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Col         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Txt         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Num         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Num = ActiveSheet.Range("A1").CurrentRegion.Count
    [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
        ReDim Ray(1 To Num, 1 To 3)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]Set[/COLOR] AcRng = Range(Range("B" & Dn.Row), Cells(Dn.Row, Columns.Count).End(xlToLeft))
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Col [COLOR="Navy"]In[/COLOR] AcRng
            [COLOR="Navy"]If[/COLOR] Col.Column = 2 [COLOR="Navy"]Then[/COLOR]
                Txt = "First"
             [COLOR="Navy"]ElseIf[/COLOR] Col.Column = AcRng.Count + 1 [COLOR="Navy"]Then[/COLOR]
                Txt = "Last"
             [COLOR="Navy"]Else[/COLOR]
                Txt = Col.Column - 1
            [COLOR="Navy"]End[/COLOR] If
                c = c + 1
            Ray(c, 1) = Dn
            Ray(c, 2) = Col
            Ray(c, 3) = Txt
        [COLOR="Navy"]Next[/COLOR] Col
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
.Range("A1").Resize(, 3) = Array("ID", "P", "Rank")
.Range("A2").Resize(c, 3) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Peter_SSs]

My attempt:

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Rearrange()<br>  <SPAN style="color:#00007F">Dim</SPAN> a, b<br>  <SPAN style="color:#00007F">Dim</SPAN> rws <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, k <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, r <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>  <SPAN style="color:#00007F">Dim</SPAN> ub1 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, ub2 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>  <br>  a = Range("A1").CurrentRegion.Value<br>  ub1 = <SPAN style="color:#00007F">UBound</SPAN>(a, 1)<br>  ub2 = <SPAN style="color:#00007F">UBound</SPAN>(a, 2)<br>  <SPAN style="color:#00007F">ReDim</SPAN> b(1 <SPAN style="color:#00007F">To</SPAN> ub1 * ub2, 1 <SPAN style="color:#00007F">To</SPAN> 3)<br>  b(1, 1) = "ID"<br>  b(1, 2) = "P"<br>  b(1, 3) = "Rank"<br>  k = 1<br>  <SPAN style="color:#00007F">For</SPAN> i = 2 <SPAN style="color:#00007F">To</SPAN> ub1<br>    r = 0<br>    <SPAN style="color:#00007F">For</SPAN> j = 2 <SPAN style="color:#00007F">To</SPAN> ub2<br>      <SPAN style="color:#00007F">If</SPAN> a(i, j) <> "" <SPAN style="color:#00007F">Then</SPAN><br>        k = k + 1<br>        r = r + 1<br>        b(k, 1) = a(i, 1)<br>        b(k, 2) = a(i, j)<br>        b(k, 3) = IIf(j = 2, "First", r)<br>      <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> j<br>    <SPAN style="color:#00007F">If</SPAN> r > 1 <SPAN style="color:#00007F">Then</SPAN> b(k, 3) = "Last"<br>  <SPAN style="color:#00007F">Next</SPAN> i<br>  Range("A1").Offset(, ub2 + 2).Resize(k, 3).Value = b<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[culyus]

Thank you very much Mick. Ray(c, 1) = Dn was highlighted in debug after I ran the macro. Does it require any special set up, like data should start with A1 etc? By the way I think I mislead by using P1, P2 etc as column headers. Actually there is no column header in the data. Thanks a lot.

 

[culyus]

Thank you very much Peter. This is amazing. It works I thought it didnt work but I found the data in DS to DU columns. Could you also teach me what to change in macro to get this into a new sheet and for the others that are not "last" or "first", how to label as "middle" when needed. Thanks so much.

My attempt:

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Rearrange()<br>**<SPAN style="color:#00007F">Dim</SPAN> a, b<br>**<SPAN style="color:#00007F">Dim</SPAN> rws <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, j <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, k <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, r <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>**<SPAN style="color:#00007F">Dim</SPAN> ub1 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, ub2 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>**<br>**a = Range("A1").CurrentRegion.Value<br>**ub1 = <SPAN style="color:#00007F">UBound</SPAN>(a, 1)<br>**ub2 = <SPAN style="color:#00007F">UBound</SPAN>(a, 2)<br>**<SPAN style="color:#00007F">ReDim</SPAN> b(1 <SPAN style="color:#00007F">To</SPAN> ub1 * ub2, 1 <SPAN style="color:#00007F">To</SPAN> 3)<br>**b(1, 1) = "ID"<br>**b(1, 2) = "P"<br>**b(1, 3) = "Rank"<br>**k = 1<br>**<SPAN style="color:#00007F">For</SPAN> i = 2 <SPAN style="color:#00007F">To</SPAN> ub1<br>****r = 0<br>****<SPAN style="color:#00007F">For</SPAN> j = 2 <SPAN style="color:#00007F">To</SPAN> ub2<br>******<SPAN style="color:#00007F">If</SPAN> a(i, j) <> "" <SPAN style="color:#00007F">Then</SPAN><br>********k = k + 1<br>********r = r + 1<br>********b(k, 1) = a(i, 1)<br>********b(k, 2) = a(i, j)<br>********b(k, 3) = IIf(j = 2, "First", r)<br>******<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>****<SPAN style="color:#00007F">Next</SPAN> j<br>****<SPAN style="color:#00007F">If</SPAN> r > 1 <SPAN style="color:#00007F">Then</SPAN> b(k, 3) = "Last"<br>**<SPAN style="color:#00007F">Next</SPAN> i<br>**Range("A1").Offset(, ub2 + 2).Resize(k, 3).Value = b<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[Peter_SSs]

Actually there is no column header in the data.

In that case, for my code, change this line

For i = 1 To ub1