Align two set of datas

[seven1four]

Hello,
I got two set of data that needs to be align by id. I need a formula/vba to go down two sets of number and insert a blank line if there's no match and go on to the next number. One set of data is a-d and the other is f-i. I was only able to find something that only insert blanks into 1 side not the other. Both list contain around 400 rows.
Thank you.

Windows 7
Office Pro 2010

Raw

id	name	desscription	$		id	name	description	spent
5	joe		5		1	albert		6
125	lisa		2		125	lisa		8
125	lisa		2		150	anne		3
126	mike		1

<tbody>
</tbody>

After

id	name	description	spent		id	name	description	spent
					1	albert		6
5	joe		5
125	lisa		4		125	lisa		8
125	lisa		2
126	mike		1
					150	anne		3

<tbody>
</tbody>

 

[MickG]

Try this:-
Data on Activesheet "A to I", Results on sheet2 , "A to I".

[COLOR="Navy"]Sub[/COLOR] MG20Jan23
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] a [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] ray [COLOR="Navy"]As[/COLOR] Variant, col [COLOR="Navy"]As[/COLOR] Variant, N1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] N2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

ray = Range("A2").Resize(UsedRange.Rows.Count, 9)
Sheets("Sheet2").Range("A:I").ClearContents
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
 col = Array(1, 6)
[COLOR="Navy"]For[/COLOR] a = 0 To 1
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(ray, 1)
        Txt = ray(n, col(a)) & ray(n, col(a) + 1)
        [COLOR="Navy"]If[/COLOR] Txt <> "" [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
                ReDim nRay(1 To UBound(ray, 1), 1 To 9)
                nRay(1, 1) = ray(n, col(a))
                nRay(1, 2) = ray(n, col(a) + 1)
                nRay(1, 3) = ray(n, col(a) + 2)
                nRay(1, 4) = ray(n, col(a) + 3)
                nRay(1, 5) = col(a)
               .Add Txt, Array(nRay, 1)
            [COLOR="Navy"]Else[/COLOR]
                Q = .Item(Txt)
                   Q(1) = Q(1) + 1
                   Q(0)(Q(1), 1) = ray(n, col(a))
                   Q(0)(Q(1), 2) = ray(n, col(a) + 1)
                   Q(0)(Q(1), 3) = ray(n, col(a) + 2)
                   Q(0)(Q(1), 4) = ray(n, col(a) + 3)
                   Q(0)(Q(1), 5) = col(a)
                .Item(Txt) = Q
         [COLOR="Navy"]End[/COLOR] If
     [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] a

Rw = 1
Sheets("Sheet2").Range("A1:I1") = Array("id", "name", "des1", "$", "  ", "id", "name", "desc", "spent")

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]For[/COLOR] n = 1 To .Item(K)(1)
        [COLOR="Navy"]If[/COLOR] .Item(K)(0)(n, 5) = 1 [COLOR="Navy"]Then[/COLOR]
            N1 = N1 + 1
        [COLOR="Navy"]Else[/COLOR]
            N2 = N2 + 1
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
    oMax = Application.Max(N1, N2)
    N1 = 0: N2 = 0
    
    c = Rw
    [COLOR="Navy"]For[/COLOR] n = 1 To .Item(K)(1)
      [COLOR="Navy"]If[/COLOR] .Item(K)(0)(n, 5) = 1 And Not IsEmpty(.Item(K)(0)(n, 1)) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        [COLOR="Navy"]For[/COLOR] Ac = 1 To 9
          [COLOR="Navy"]If[/COLOR] Not Ac = 5 [COLOR="Navy"]Then[/COLOR]
            Sheets("Sheet2").Cells(c, Ac) = .Item(K)(0)(n, Ac)
          [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Ac
    [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]Next[/COLOR] n
    
    c = Rw
    [COLOR="Navy"]For[/COLOR] n = 1 To .Item(K)(1)
    [COLOR="Navy"]If[/COLOR] .Item(K)(0)(n, 5) = 6 And Not IsEmpty(.Item(K)(0)(n, 1)) [COLOR="Navy"]Then[/COLOR]
    c = c + 1
        [COLOR="Navy"]For[/COLOR] Ac = 1 To 9
          [COLOR="Navy"]If[/COLOR] Not Ac = 5 [COLOR="Navy"]Then[/COLOR]
            Sheets("Sheet2").Cells(c, 5 + Ac) = .Item(K)(0)(n, Ac)
          [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Ac
    [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
Rw = Rw + oMax
c = Rw
oMax = 0
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[seven1four]

I get a run-time error '424':
Object Required

ray = Range("A2").Resize(UsedRange.Rows.Count, 9)

Thanks

 

[MickG]

Sorry, If you are using in a module you will need to change that line as below.

With ActiveSheet
    ray = .Range("A2").Resize(.UsedRange.Rows.Count, 9)
End With

Here is an example file:-
https://app.box.com/s/y4d6zlct3oklzcqnz2yyj8x0p5tpvdbk