VBA to convert a Tabular Report to a Matrix view

Coenieh

New Member
Joined
Oct 18, 2018
Messages
19
Hi Everyone,

I have a report which I generate on a regular basis and need to convert from a tabular view to a matrix view for readability.

I use Excel 2013

I would appreciate if anyone could assist me with some VBA code to accomplish the following:


  • Delete all non-required columns, in this case " B to E, G, H, I, K to U, W to AB, AD to AG, AI to AO (35 of the original 41 to be deleted) The same columns will always be deleted.
  • Then change the layout and view to a matrix, please see "Converted Report" below.

Some of the remaining column headers from the original report will be used as the column headers for the new report with the exception of column "F", which will be the 6 different records, or course names, listed in the Original Report and will be column headers for columns "B" to "G" in the new report. These 6 headers will always remain the same.

Below is a sample data set from the Original Report, which have hundreds more records. The non-required columns, as listed above, have already been removed for a better view, the remaining columns in " ":

Original Report:

"A"
Learner

<tbody>
</tbody>
"F"
Course

<tbody>
</tbody>
"J"
Completion Date

<tbody>
</tbody>
"V"
LOCATION CODE

<tbody>
</tbody>
"AC"
mgrname

<tbody>
</tbody>
"AH"
POSITION 1

<tbody>
</tbody>
Ali Md AKBAR

<tbody>
</tbody>
ELDER ABUSE, MISSING PERSONS AND COMPULSORY REPORTING

<tbody>
</tbody>
15-Jun-17

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Ali Md AKBAR

<tbody>
</tbody>
FIRE SAFETY: THE BASIC PRINCIPLES

<tbody>
</tbody>
20-Feb-19

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Ali Md AKBAR

<tbody>
</tbody>
FOOD SAFETY

<tbody>
</tbody>
30-Oct-18

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Ali Md AKBAR

<tbody>
</tbody>
INFECTION CONTROL: AN OVERVIEW (R-AU)

<tbody>
</tbody>
19-Feb-19

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Ali Md AKBAR

<tbody>
</tbody>
WHS: PREVENTING MUSCULOSKELETAL INJURY AT WORK (R-AU)

<tbody>
</tbody>
11-Feb-19

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Ali Md AKBAR

<tbody>
</tbody>
WHS: SAFE MANUAL HANDLING (AUS)

<tbody>
</tbody>
04-Apr-18

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Alina Sophia SLATER

<tbody>
</tbody>
ELDER ABUSE, MISSING PERSONS AND COMPULSORY REPORTING

<tbody>
</tbody>
20-Jun-17

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Alina Sophia SLATER

<tbody>
</tbody>
FOOD SAFETY

<tbody>
</tbody>
25-Jun-18

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Alina Sophia SLATER

<tbody>
</tbody>
WHS: SAFE MANUAL HANDLING (AUS)

<tbody>
</tbody>
20-Jun-18

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Alison Mary BROWN

<tbody>
</tbody>

<tbody>
</tbody>
ELDER ABUSE, MISSING PERSONS AND COMPULSORY REPORTING

<tbody>
</tbody>
16-Mar-18

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Jessie Twan Tee HO

<tbody>
</tbody>
Physiotherapist - Residential

<tbody>
</tbody>
Alison Mary BROWN

<tbody>
</tbody>

<tbody>
</tbody>
WHS: PREVENTING MUSCULOSKELETAL INJURY AT WORK (R-AU)

<tbody>
</tbody>
02-Apr-19

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Jessie Twan Tee HO

<tbody>
</tbody>
Physiotherapist - Residential

<tbody>
</tbody>
Alison Mary BROWN

<tbody>
</tbody>

<tbody>
</tbody>
WHS: SAFE MANUAL HANDLING (AUS)

<tbody>
</tbody>
19-Jul-18

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Jessie Twan Tee HO

<tbody>
</tbody>
Physiotherapist - Residential

<tbody>
</tbody>
Amandeep KAUR

<tbody>
</tbody>
ELDER ABUSE, MISSING PERSONS AND COMPULSORY REPORTING

<tbody>
</tbody>
14-Dec-17

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker
Amandeep KAUR

<tbody>
</tbody>
FOOD SAFETY

<tbody>
</tbody>
21-Jun-18

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Amandeep KAUR

<tbody>
</tbody>
INFECTION CONTROL: AN OVERVIEW (R-AU)

<tbody>
</tbody>
19-Mar-19

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Amandeep KAUR

<tbody>
</tbody>
WHS: PREVENTING MUSCULOSKELETAL INJURY AT WORK (R-AU)

<tbody>
</tbody>
19-Mar-19

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Amandeep KAUR

<tbody>
</tbody>
WHS: SAFE MANUAL HANDLING (AUS)

<tbody>
</tbody>
21-Mar-18

<tbody>
</tbody>
MHH

<tbody>
</tbody>
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>

<tbody>
</tbody>


Converted Report: (This is what the new report will look like)
"A"

Learner
"B"​
ELDER ABUSE, MISSING PERSONS AND COMPULSORY REPORTING

<tbody>
</tbody>
"C"​
FIRE SAFETY: THE BASIC PRINCIPLES

<tbody>
</tbody>
"D"​
FOOD SAFETY

<tbody>
</tbody>
"E"​
INFECTION CONTROL: AN OVERVIEW (R-AU)

<tbody>
</tbody>
"F"​
WHS: PREVENTING MUSCULOSKELETAL INJURY AT WORK (R-AU)

<tbody>
</tbody>
"G"​
WHS: SAFE MANUAL HANDLING (AUS)

<tbody>
</tbody>
"H"
LOCATION CODE
"I"​
mgrname

<tbody>
</tbody>
"J"​
POSITION 1

<tbody>
</tbody>
Ali Md AKBAR

<tbody>
</tbody>
15-Jun-17

<tbody>
</tbody>
20-Feb-19

<tbody>
</tbody>
30-Oct-18

<tbody>
</tbody>
19-Feb-19

<tbody>
</tbody>
11-Feb-19

<tbody>
</tbody>
04-Apr-18

<tbody>
</tbody>
MHH
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Alina Sophia SLATER

<tbody>
</tbody>
20-Jun-17

<tbody>
</tbody>
25-Jun-18

<tbody>
</tbody>
20-Jun-18

<tbody>
</tbody>
MHH
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>
Alison Mary BROWN

<tbody>
</tbody>
16-Mar-18

<tbody>
</tbody>
02-Apr-19

<tbody>
</tbody>
19-Jul-18

<tbody>
</tbody>
MHH
Jessie Twan Tee HO

<tbody>
</tbody>
Physiotherapist - Residential

<tbody>
</tbody>
Amandeep KAUR

<tbody>
</tbody>
14-Dec-17

<tbody>
</tbody>
21-Jun-18

<tbody>
</tbody>
19-Mar-19

<tbody>
</tbody>
19-Mar-19

<tbody>
</tbody>
21-Mar-18

<tbody>
</tbody>
MHH
Chui Kiong KING

<tbody>
</tbody>
Care Worker

<tbody>
</tbody>

<tbody>
</tbody>


Hopefully I have explained the requirement in such a way that it makes sense. Please let me know should you require more information.
 
Last edited:

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Hi All,

I have managed to write code to delete the unwanted columns based on the Header. This might not be the most efficient way, so please would appreciate any pointers on how to make the code more efficient.

Code:
Sub DeleteSpecificColumn()    Set MR = Range("A1:AO1")
    For Each cell In MR
        If cell.Value = "UID" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Email" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Course ID" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Course External ID" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Course Description" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Score" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Due Date" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Status" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Continuing Education Credits" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Required" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Total Time in Course (seconds)" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Programs" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Groups" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Enrollment Date" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Archived Date" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "Certificate URL" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "BUSINESS UNIT" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "employee code" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "mgr1email" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "mgr2code" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "mgr2email" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "mgr2name" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "mgr2uniqueid" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "mgrcode" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "p1 group" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "p2 group" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "p3group" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "p4 group" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "POSITION 2" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "POSITION 3" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "POSITION 4" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "WAP1Code" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "WAP2Code" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "wap3code" Then cell.EntireColumn.Delete
    Next
    For Each cell In MR
        If cell.Value = "wap4code" Then cell.EntireColumn.Delete
    Next
End Sub


I now need to format the remaining columns into the matrix view as per my original post above.

Would appreciate any assistance with the last part of the code.

Thank you in advance.
 
Upvote 0
Try this for results on sheet2, from data on sheet1 starting "A1" ="Learner".
Code:
[COLOR="Navy"]Sub[/COLOR] MG20Apr12
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] oHds [COLOR="Navy"]As[/COLOR] Variant, Dic [COLOR="Navy"]As[/COLOR] Object, Hd [COLOR="Navy"]As[/COLOR] Variant
 
 oHds = Array("Learner", "ELDER ABUSE, MISSING PERSONS AND COMPULSORY REPORTING", _
 "FIRE SAFETY: THE BASIC PRINCIPLES", "FOOD SAFETY", "INFECTION CONTROL: AN OVERVIEW (R-AU)", _
 "WHS: PREVENTING MUSCULOSKELETAL INJURY AT WORK (R-AU)", "WHS: SAFE MANUAL HANDLING (AUS)", _
 "LOCATION CODE", "mgrname", "POSITION 1")

[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

ReDim Ray(1 To Rng.Count, 1 To UBound(oHds) + 1)
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Hd [COLOR="Navy"]In[/COLOR] oHds
                Dic(Hd) = Dic.Count
                Ray(1, Dic.Count) = Hd
            [COLOR="Navy"]Next[/COLOR]

c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Temp = Dn.Value [COLOR="Navy"]Then[/COLOR] c = c + 1
        [COLOR="Navy"]If[/COLOR] Dic.exists(Dn.Offset(, 5).Value) [COLOR="Navy"]Then[/COLOR]
            Ray(c, 1) = Dn.Value
            Ray(c, Dic(Dn.Offset(, 5).Value) + 1) = Dn.Offset(, 9)
                [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ac [COLOR="Navy"]In[/COLOR] Array(21, 28, 33)
                    Ray(c, Dic(Rng(1).Offset(-1, Ac).Value) + 1) = Dn.Offset(, Ac)
                [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]End[/COLOR] If
Temp = Dn.Value
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, UBound(oHds) + 1)
    .Value = Ray
    .Borders.Weight = 2
    .Parent.Rows(1).WrapText = True
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

Thank you so much, works like a charm. Your code does exactly what I was looking to do. I really appreciate all the effort you have put into developing this for me, you have truly lighten my burden significantly.

Once again thanks a million.

Kind Regards

Coenie
 
Upvote 0
You're welcome

Hi Mick,

If I may ask one more question/favour, instead of a static number of courses to look as per currently in the report and code, how would I go about to determine what courses are listed in column "F" "Course" and then use them as headers and then complete the report accordingly? The rest of the report and headers will remain as is.

I'm just thinking future state where there might be more or different courses listed instead of just what is listed now.

Thanks

Coenie
 
Upvote 0
Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG24Apr00
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray() [COLOR="Navy"]As[/COLOR] Variant, Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
 
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With

    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Offset(, 5)
                [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                    Dic(Dn.Value) = Dic.Count + 1
                    ReDim Preserve Ray(1 To Rng.Count, 1 To Dic.Count + 1)
                    Ray(1, 1) = "Learner"
                    Ray(1, Dic.Count + 1) = Dn.Value
                [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]Next[/COLOR]
    
    ReDim Preserve Ray(1 To Rng.Count, 1 To Dic.Count + 4)
        Dic(Rng(1).Offset(-1, 21).Value) = Dic.Count + 1
        Ray(1, Dic.Count + 1) = Rng(1).Offset(-1, 21)
        Dic(Rng(1).Offset(-1, 28).Value) = Dic.Count + 1
        Ray(1, Dic.Count + 1) = Rng(1).Offset(-1, 28)
        Dic(Rng(1).Offset(-1, 33).Value) = Dic.Count + 1
        Ray(1, Dic.Count + 1) = Rng(1).Offset(-1, 33)
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Temp = Dn.Value [COLOR="Navy"]Then[/COLOR] c = c + 1
        [COLOR="Navy"]If[/COLOR] Dic.exists(Dn.Offset(, 5).Value) [COLOR="Navy"]Then[/COLOR]
            Ray(c, 1) = Dn.Value
            Ray(c, Dic(Dn.Offset(, 5).Value) + 1) = Dn.Offset(, 9)
               
                [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ac [COLOR="Navy"]In[/COLOR] Array(21, 28, 33)
                    Ray(c, Dic(Rng(1).Offset(-1, Ac).Value) + 1) = Dn.Offset(, Ac)
                [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]End[/COLOR] If
Temp = Dn.Value
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, UBound(Ray, 2))
    .Value = Ray
    .Borders.Weight = 2
    .Parent.Rows(1).WrapText = True
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

Once again, thank you very much, it works 100% as required. Really appreciate all your assistance.

Kind Regards

Coenie
 
Upvote 0

Forum statistics

Threads
1,213,556
Messages
6,114,284
Members
448,562
Latest member
Flashbond

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top