# Thread: Need Help for Rearranging Data with Macro or Formula Thanks: 0 Likes: 0

1. ## Need Help for Rearranging Data with Macro or Formula

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,

2. ## Re: Need Help for Rearranging Data with Macro or Formula

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

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

3. ## Re: Need Help for Rearranging Data with Macro or Formula

My attempt:

Sub Rearrange()
Dim a, b
Dim rws As Long, i As Long, j As Long, k As Long, r As Long
Dim ub1 As Long, ub2 As Long

a = Range("A1").CurrentRegion.Value
ub1 = UBound(a, 1)
ub2 = UBound(a, 2)
ReDim b(1 To ub1 * ub2, 1 To 3)
b(1, 1) = "ID"
b(1, 2) = "P"
b(1, 3) = "Rank"
k = 1
For i = 2 To ub1
r = 0
For j = 2 To ub2
If a(i, j) <> "" Then
k = k + 1
r = r + 1
b(k, 1) = a(i, 1)
b(k, 2) = a(i, j)
b(k, 3) = IIf(j = 2, "First", r)
End If
Next j
If r > 1 Then b(k, 3) = "Last"
Next i
Range("A1").Offset(, ub2 + 2).Resize(k, 3).Value = b
End Sub

4. ## Re: Need Help for Rearranging Data with Macro or Formula

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.

5. ## Re: Need Help for Rearranging Data with Macro or Formula

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.

Originally Posted by Peter_SSs
My attempt:

Sub Rearrange()
**Dim a, b
**Dim rws As Long, i As Long, j As Long, k As Long, r As Long
**Dim ub1 As Long, ub2 As Long
**
**a = Range("A1").CurrentRegion.Value
**ub1 = UBound(a, 1)
**ub2 = UBound(a, 2)
**ReDim b(1 To ub1 * ub2, 1 To 3)
**b(1, 1) = "ID"
**b(1, 2) = "P"
**b(1, 3) = "Rank"
**k = 1
**For i = 2 To ub1
****r = 0
****For j = 2 To ub2
******If a(i, j) <> "" Then
********k = k + 1
********r = r + 1
********b(k, 1) = a(i, 1)
********b(k, 2) = a(i, j)
********b(k, 3) = IIf(j = 2, "First", r)
******End If
****Next j
****If r > 1 Then b(k, 3) = "Last"
**Next i
**Range("A1").Offset(, ub2 + 2).Resize(k, 3).Value = b
End Sub

6. ## Re: Need Help for Rearranging Data with Macro or Formula

Originally Posted by culyus
Actually there is no column header in the data.
In that case, for my code, change this line
Code:
`For i = 1 To ub1`