Reformat Data based on Multiple Unique Values for fixed List

[hassanleo1987]

Hi,

I have a large data set of multiple columns (maximum 10) and rows more than 50K.
The data set has 2 parts.
1st part included a single column of unique values (alpha-numeric) only. let call it IDs
2nd part is a table where unique values from part 1 are linked together with 2 separate values which we'll call left and right.
The linkup is called 2-way relationship, which means IDs will have 2 types of values, one of right side and one on left side. When looking for unique values on the right side, the ID value will be filters from left column and vice versa.
There are duplications of data when filtering this way but they are ignored.

I need to get this list sorted in a way the for every ID value from part 1, there will be 2 side of table where unique values of right and left column are listed. The number of values on left and right are variable so which ever value is maximum, will determine the number of rows needed for each ID. While looking up unique left and right values, the 2 Value columns i.e., Value 1 and Value 2 will be looked up for both sides.

Final step is to apply formatting, each unique ID along with its left, right and values should be in a single border box to identify as unique set.

Currently I am all these steps using arrays, which takes a lot of time and I have to do it in multiple parts.

Is there a way, this could be done using VBA where I can specify the ID column, Left, right and value columns and the code will sort the data in the required format.

Please if somebody can help!

 

[Akuini]

One more question:
Some items exist in the Data but not in unique values, such as G,H,I..etc.
So it's possible that some items exist in the Data but not in unique values?

 

[hassanleo1987]

One more question:
Some items exist in the Data but not in unique values, such as G,H,I..etc.
So it's possible that some items exist in the Data but not in unique values?

I just realize a mistake I make with unique value list. That list should contain all values uptill S as can be seen in data table. Actually when I made that example data set. I just isolated 6 unique value to show the complete set of relationships of those only. All other values shown in data table should also be part of unique values.

In conclusion, all unique values in right and left column are part of unique ID set but just for the seek of showing 6 complete sets, i didn't include them in unique ID list.

Sorry for the confusion.

 

[hassanleo1987]

One more question:
Some items exist in the Data but not in unique values, such as G,H,I..etc.
So it's possible that some items exist in the Data but not in unique values?

This example should have been like this!

Complete left and right relationship for 6 IDs A ~ F and remaining ID should also be part of unique list.

Example.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2				Data:						Result:
3		Unique		Left	Right	Value 1	Value 2			Value 1	Value 2	Left	Unique	Right	Value 1	Value 2
4		A		C	E	1	0			0	1	G	A	C	1	0
5		B		F	K	2	40
6		C		C	D	1	0			0	1	I	B	C	2	40
7		D		D	L	1	0
8		E		C	M	1	25			0	1	A	C	E	1	0
9		F		F	N	3	25			40	2	B	C	D	1	0
10		G		A	C	1	0						C	M	1	25
11		H		D	O	2	50
12		I		E	F	1	0			0	1	C	D	L	1	0
13		J		B	C	2	40						D	O	2	50
14		K		D	P	1	0						D	P	1	0
15		L		F	Q	2	25
16		M		F	R	2	25			0	1	C	E	F	1	0
17		N		F	S	1	0			0	1	H	E
18		O		C	D	1	0
19		P		G	A	1	0			0	1	H	F	K	2	40
20		Q		A	C	1	0			0	1	E	F	N	3	25
21		R		H	E	1	0			0	3	J	F	Q	2	25
22		S		H	F	1	0						F	R	2	25
23				E	F	1	0						F	S	1	0
24				B	C	2	40
25				I	B	1	0
26				J	F	3	0
27
Data

Cell Formulas
Range	Formula
J4:J24	J4	=IFERROR(INDEX(Data!$G$4:$G$26,MATCH(1,($M4=Data!$E$4:$E$26)*($L4=Data!$D$4:$D$26),0)),"")
K4:K24	K4	=IFERROR(INDEX(Data!$F$4:$F$26,MATCH(1,($M4=Data!$E$4:$E$26)*($L4=Data!$D$4:$D$26),0)),"")
O4:O24	O4	=IFERROR(INDEX(Data!$F$4:$F$26,MATCH(1,($M4=Data!$D$4:$D$26)*($N4=Data!$E$4:$E$26),0)),"")
P4:P24	P4	=IFERROR(INDEX(Data!$G$4:$G$26,MATCH(1,($M4=Data!$D$4:$D$26)*($N4=Data!$E$4:$E$26),0)),"")
Press CTRL+SHIFT+ENTER to enter array formulas.

 

[Akuini]

Try this:
1. To make it easier to code & make it faster I set up the result in ascending order. You see in cell L9:L20, the result show different order than your example. Is it a problem?
2. I commented this part:
'to set cells borders, it could slow down the code significantly
'With Range(Cells(w + 4, "J"), Cells(ww + 2, "P"))
' .Borders(xlEdgeLeft).LineStyle = xlContinuous
' .Borders(xlEdgeRight).LineStyle = xlContinuous
' .Borders(xlEdgeBottom).LineStyle = xlContinuous
' .Borders(xlEdgeTop).LineStyle = xlContinuous
'End With
it is to format cells borders, it could slow down the code significantly. So test it without formatting the borders first on your original data.

Option Explicit
Sub hassanleo1987a()
Dim i As Long, j As Long, k As Long, m As Long, n As Long, w As Long, ww As Long
Dim u As Long, q As Long, p As Long
Dim va, vb, vc, vd, vx, vz, t, vcx, vdx, x, fm
Dim c As Range
t = Timer
Application.EnableEvents = False
Application.ScreenUpdating = False
With Range("b3", Cells(Rows.Count, "B").End(xlUp))
.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes
End With

vx = Application.Transpose(Range("b4", Cells(Rows.Count, "b").End(xlUp)))

va = Range("d3", Cells(Rows.Count, "d").End(xlUp)).Resize(, 4)

Set c = Range("z3").Resize(UBound(va, 1), 4)
c = va
c.Sort Key1:=c.Cells(1, 2), Order1:=xlAscending, Key2:=c.Cells(1, 1), Order2:=xlAscending, Header:=xlYes
vb = c: c = va
c.Sort Key1:=c.Cells(1, 1), Order1:=xlAscending, Key2:=c.Cells(1, 2), Order2:=xlAscending, Header:=xlYes
va = c
c.ClearContents


ReDim vc(1 To UBound(va, 1), 1 To 4)
ReDim vd(1 To UBound(va, 1), 1 To 4)

For i = 2 To UBound(va, 1)
    j = i
        Do
            i = i + 1
            If i > UBound(va, 1) Then Exit Do
        Loop While va(i, 1) = va(i - 1, 1)
        i = i - 1
        
        For k = j To i
            n = n + 1
            For m = 1 To 4
                If k > j And va(k, 2) = va(k - 1, 2) Then n = n - 1: Exit For
                vc(n, m) = va(k, m)
            Next
        Next
Next

n = 0
For i = 2 To UBound(vb, 1)
    j = i
        Do
            i = i + 1
            If i > UBound(vb, 1) Then Exit Do
        Loop While vb(i, 1) = vb(i - 1, 1)
        i = i - 1
        
        For k = j To i
            n = n + 1
            For m = 1 To 4
                If k > j And vb(k, 2) = vb(k - 1, 2) Then n = n - 1: Exit For
                vd(n, m) = vb(k, m)
            Next
        Next
Next

'clear cells border
With Range("J:P")
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With

ReDim vz(1 To UBound(va, 1) + UBound(vb), 1 To 7)
vcx = Application.Index(vc, , 1)
vdx = Application.Index(vd, , 2)

For Each x In vx
fm = Application.Match(x, vcx, 0)
    If IsNumeric(fm) Then
        u = w + 1
        Do
            u = u + 1
            vz(u, 4) = vc(fm, 1)
            vz(u, 5) = vc(fm, 2)
            vz(u, 6) = vc(fm, 3)
            vz(u, 7) = vc(fm, 4)
            fm = fm + 1
        Loop While vc(fm, 1) = x
        p = u
    End If

fm = Application.Match(x, vdx, 0)
    If IsNumeric(fm) Then
        u = w + 1
        Do
            u = u + 1
            vz(u, 4) = vd(fm, 2)
            vz(u, 3) = vd(fm, 1)
            vz(u, 2) = vd(fm, 3)
            vz(u, 1) = vd(fm, 4)
            fm = fm + 1
        Loop While vd(fm, 2) = x
        q = u
    End If

If p > q Then ww = p Else ww = q

'=====================================
'to format cells borders, it could slow down the code significantly
'With Range(Cells(w + 4, "J"), Cells(ww + 2, "P"))
' .Borders(xlEdgeLeft).LineStyle = xlContinuous
' .Borders(xlEdgeRight).LineStyle = xlContinuous
' .Borders(xlEdgeBottom).LineStyle = xlContinuous
' .Borders(xlEdgeTop).LineStyle = xlContinuous
'End With
'======================================

w = ww
Next

Range("J3").Resize(UBound(vz, 1), 7) = vz
Application.EnableEvents = True
Application.ScreenUpdating = True
Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

hassanleo1987 - Reformat Data 1.xlsm
	J	K	L	M	N	O	P
3
4	0	1	G	A	C	1	0
5
6	0	1	I	B	C	2	40
7
8	0	1	A	C	D	1	0
9	40	2	B	C	E	1	0
10				C	M	1	25
11
12	0	1	C	D	L	1	0
13				D	O	2	50
14				D	P	1	0
15
16	0	1	C	E	F	1	0
17	0	1	H	E
18
19	0	1	E	F	K	2	40
20	0	1	H	F	N	3	25
21	0	3	J	F	Q	2	25
22				F	R	2	25
23				F	S	1	0
24
25				G	A	1	0
26
27				H	E	1	0
28				H	F	1	0
29
30				I	B	1	0
31
32				J	F	3	0
33
34	40	2	F	K
35
36	0	1	D	L
37
38	25	1	C	M
39
40	25	3	F	N
41
42	50	2	D	O
43
44	0	1	D	P
45
46	25	2	F	Q
47
48	25	2	F	R
49
50	0	1	F	S
Data

 

[hassanleo1987]

Try this:
1. To make it easier to code & make it faster I set up the result in ascending order. You see in cell L9:L20, the result show different order than your example. Is it a problem?
2. I commented this part:
'to set cells borders, it could slow down the code significantly
'With Range(Cells(w + 4, "J"), Cells(ww + 2, "P"))
' .Borders(xlEdgeLeft).LineStyle = xlContinuous
' .Borders(xlEdgeRight).LineStyle = xlContinuous
' .Borders(xlEdgeBottom).LineStyle = xlContinuous
' .Borders(xlEdgeTop).LineStyle = xlContinuous
'End With
it is to format cells borders, it could slow down the code significantly. So test it without formatting the borders first on your original data.

Option Explicit
Sub hassanleo1987a()
Dim i As Long, j As Long, k As Long, m As Long, n As Long, w As Long, ww As Long
Dim u As Long, q As Long, p As Long
Dim va, vb, vc, vd, vx, vz, t, vcx, vdx, x, fm
Dim c As Range
t = Timer
Application.EnableEvents = False
Application.ScreenUpdating = False
With Range("b3", Cells(Rows.Count, "B").End(xlUp))
.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes
End With

vx = Application.Transpose(Range("b4", Cells(Rows.Count, "b").End(xlUp)))

va = Range("d3", Cells(Rows.Count, "d").End(xlUp)).Resize(, 4)

Set c = Range("z3").Resize(UBound(va, 1), 4)
c = va
c.Sort Key1:=c.Cells(1, 2), Order1:=xlAscending, Key2:=c.Cells(1, 1), Order2:=xlAscending, Header:=xlYes
vb = c: c = va
c.Sort Key1:=c.Cells(1, 1), Order1:=xlAscending, Key2:=c.Cells(1, 2), Order2:=xlAscending, Header:=xlYes
va = c
c.ClearContents


ReDim vc(1 To UBound(va, 1), 1 To 4)
ReDim vd(1 To UBound(va, 1), 1 To 4)

For i = 2 To UBound(va, 1)
    j = i
        Do
            i = i + 1
            If i > UBound(va, 1) Then Exit Do
        Loop While va(i, 1) = va(i - 1, 1)
        i = i - 1
      
        For k = j To i
            n = n + 1
            For m = 1 To 4
                If k > j And va(k, 2) = va(k - 1, 2) Then n = n - 1: Exit For
                vc(n, m) = va(k, m)
            Next
        Next
Next

n = 0
For i = 2 To UBound(vb, 1)
    j = i
        Do
            i = i + 1
            If i > UBound(vb, 1) Then Exit Do
        Loop While vb(i, 1) = vb(i - 1, 1)
        i = i - 1
      
        For k = j To i
            n = n + 1
            For m = 1 To 4
                If k > j And vb(k, 2) = vb(k - 1, 2) Then n = n - 1: Exit For
                vd(n, m) = vb(k, m)
            Next
        Next
Next

'clear cells border
With Range("J:P")
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With

ReDim vz(1 To UBound(va, 1) + UBound(vb), 1 To 7)
vcx = Application.Index(vc, , 1)
vdx = Application.Index(vd, , 2)

For Each x In vx
fm = Application.Match(x, vcx, 0)
    If IsNumeric(fm) Then
        u = w + 1
        Do
            u = u + 1
            vz(u, 4) = vc(fm, 1)
            vz(u, 5) = vc(fm, 2)
            vz(u, 6) = vc(fm, 3)
            vz(u, 7) = vc(fm, 4)
            fm = fm + 1
        Loop While vc(fm, 1) = x
        p = u
    End If

fm = Application.Match(x, vdx, 0)
    If IsNumeric(fm) Then
        u = w + 1
        Do
            u = u + 1
            vz(u, 4) = vd(fm, 2)
            vz(u, 3) = vd(fm, 1)
            vz(u, 2) = vd(fm, 3)
            vz(u, 1) = vd(fm, 4)
            fm = fm + 1
        Loop While vd(fm, 2) = x
        q = u
    End If

If p > q Then ww = p Else ww = q

'=====================================
'to format cells borders, it could slow down the code significantly
'With Range(Cells(w + 4, "J"), Cells(ww + 2, "P"))
' .Borders(xlEdgeLeft).LineStyle = xlContinuous
' .Borders(xlEdgeRight).LineStyle = xlContinuous
' .Borders(xlEdgeBottom).LineStyle = xlContinuous
' .Borders(xlEdgeTop).LineStyle = xlContinuous
'End With
'======================================

w = ww
Next

Range("J3").Resize(UBound(vz, 1), 7) = vz
Application.EnableEvents = True
Application.ScreenUpdating = True
Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub

hassanleo1987 - Reformat Data 1.xlsm
	J	K	L	M	N	O	P
3
4	0	1	G	A	C	1	0
5
6	0	1	I	B	C	2	40
7
8	0	1	A	C	D	1	0
9	40	2	B	C	E	1	0
10				C	M	1	25
11
12	0	1	C	D	L	1	0
13				D	O	2	50
14				D	P	1	0
15
16	0	1	C	E	F	1	0
17	0	1	H	E
18
19	0	1	E	F	K	2	40
20	0	1	H	F	N	3	25
21	0	3	J	F	Q	2	25
22				F	R	2	25
23				F	S	1	0
24
25				G	A	1	0
26
27				H	E	1	0
28				H	F	1	0
29
30				I	B	1	0
31
32				J	F	3	0
33
34	40	2	F	K
35
36	0	1	D	L
37
38	25	1	C	M
39
40	25	3	F	N
41
42	50	2	D	O
43
44	0	1	D	P
45
46	25	2	F	Q
47
48	25	2	F	R
49
50	0	1	F	S
Data

I have tried it both way, with and without cell border portion. Both are working great. With border code, it took around 4 minutes to process the data set with required group borders.

@Akuini You are the best! Thanks a lot for your time and help!

It took me 4 days from extraction to data transformation in this format using just the formulations! I am more than happy with 4 minutes.

Again, appreciate your help with my unique problems!!! ????

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.