Subroutine to Tabulate X, Y Ordinal Data

[Juggler_IN]

I need help (VBA Sub) in converting a random two column X, Y data into a summary table which counts number of matched pairs for the ordinal data in X,Y pairs.

Both X and Y can take only integers (1 to 100).

For Example: Consider the following X,Y Data and its Summary Table -

X	Y			[Y] (1)	[Y] (2)	[Y] (3)	[Y] (4)	[Y] (5)
2	3		[X] (1)	1	1	0	0	0
3	1		[X] (2)	1	0	2	0	1
5	5		[X] (3)	1	0	0	0	0
2	1		[X] (4)	1	0	0	1	0
2	3		[X] (5)	0	0	0	0	1
4	1
1	2
1	1
2	5
4	4

<tbody>
</tbody>

Basically I am looking for a method which can create the summary table on the right for X,Y data with possible values 1 to 100, all integers.

Looking for a VBA subroutine to do this.

 

[MickG]

Try this for results starting "D1", based on columns "A & B"

[COLOR="Navy"]Sub[/COLOR] MG05Sep24
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] sp [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
oMax = Application.Max(Rng.Resize(, 2))
ReDim ray(1 To oMax + 1, 1 To oMax + 1)
   ray(1, 1) = "X/Y"
    [COLOR="Navy"]For[/COLOR] n = 2 To oMax + 1
        ray(1, n) = "[Y](" & n - 1 & ")"
        ray(n, 1) = "[X](" & n - 1 & ")"
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Txt = Dn.Value & "," & Dn.Offset(, 1).Value
    [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
        .Add Txt, 1
    [COLOR="Navy"]Else[/COLOR]
        .Item(Txt) = .Item(Txt) + 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    sp = Split(K, ",")
    ray(sp(0) + 1, sp(1) + 1) = .Item(K)
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Range("D1").Resize(oMax + 1, oMax + 1)
    .Value = ray
    .SpecialCells(xlCellTypeBlanks).Value = 0
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Juggler_IN]

Thanks Mick,

Just getting an error if there is no empty cell then

[COLOR=#333333].SpecialCells(xlCellTypeBlanks).Value = 0[/COLOR]

is resulting in Run-time Error - No Cells Found; how can this be fixed to handle non-empty cells alongside empty cells?

Otherwise, this sub does the job!

 

[MickG]

You're welocme

Just change the lines below by adding the "On Error" bits

With Range("D1").Resize(oMax + 1, oMax + 1)
    .Value = ray
  On Error Resume Next
    .SpecialCells(xlCellTypeBlanks).Value = 0
  On Error GoTo 0
    .Borders.Weight = 2
    .Columns.AutoFit
End With
End With