VBA to generate report

[dsubash]

Hi Experts,

Need some VBA Code for my reports. Given below the screenshot of my database and reports page. I have used normal excel formulas to derive at this report. But it takes too much time to generate and sometimes excel hangs up.

Sheet1 (Data)

Sample Test Details TDM.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	No.	Sample No.	Sample ID	Test	Result	Register Date	Name	Age	Gender	Case No.	Bed No.	Doctor	Department	Diagnosis	Remark	Checker	Test Date
2	1	106233900	0106233900	UREA	29	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:13
3	2	106233900	0106233900	SGOT	19.6	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:16
4	3	106233900	0106233900	GGT	24.6	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:17
5	4	106233900	0106233900	TP	5.15	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:17
6	5	106233900	0106233900	CHOL	169	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:15
7	6	106233900	0106233900	BILL-D	0.32	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:16
8	7	106233900	0106233900	ALP	70	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:16
9	8	106233900	0106233900	BILL-T	1	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:15
10	9	106233900	0106233900	CAL A	11.3	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:14
11	10	106233900	0106233900	TGL	137	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:15
12	11	106233900	0106233900	SGPT	25	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:16
13	12	106233900	0106233900	CREATIN	1.03	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:18
14	13	106233900	0106233900	ALB	4.03	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:17
15	14	106233900	0106233900	UA	5.18	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:14
16	15	106233900	0106233900	GLUC	112	01/01/2025 08:57	NithishKumar	0Years	Male								01/01/2025 09:14
17	16	106234100	0106234100	PHOS	4.12	01/01/2025 08:57	Maharaja	0Years	Male								01/01/2025 09:21
18	17	106234100	0106234100	UA	6.3	01/01/2025 08:57	Maharaja	0Years	Male								01/01/2025 09:20
19	18	106234100	0106234100	TGL	151	01/01/2025 08:57	Maharaja	0Years	Male								01/01/2025 09:21
20	19	106234100	0106234100	UREA	54	01/01/2025 08:57	Maharaja	0Years	Male								01/01/2025 09:19
21	20	106234100	0106234100	CHOL	191	01/01/2025 08:57	Maharaja	0Years	Male								01/01/2025 09:20
22	21	106234100	0106234100	GLUC	116	01/01/2025 08:57	Maharaja	0Years	Male								01/01/2025 09:19
23	22	106234100	0106234100	CAL A	10.4	01/01/2025 08:57	Maharaja	0Years	Male								01/01/2025 09:20
24	23	106234100	0106234100	CREATIN	2.25	01/01/2025 08:57	Maharaja	0Years	Male								01/01/2025 09:21
25	24	106234000	0106234000	CREATIN	0.86	01/01/2025 08:58	VetrivelS	0Years	Male								01/01/2025 09:19
26	25	106234000	0106234000	CHOL	120	01/01/2025 08:58	VetrivelS	0Years	Male								01/01/2025 09:18
27	26	106234000	0106234000	TGL	192	01/01/2025 08:58	VetrivelS	0Years	Male								01/01/2025 09:19
28	27	106234000	0106234000	GLUC	402	01/01/2025 08:58	VetrivelS	0Years	Male								01/01/2025 09:18
29	28	106234200	0106234200	GLUC	97	01/01/2025 09:59	AnandKumarV	0Years	Male								01/01/2025 10:13
30	29	500573600	0500573600	GLUC	150	01/01/2025 10:19	John	0Years	Male								01/01/2025 10:34
31	30	500573500	0500573500	GLUC	94	01/01/2025 10:19	Pooranima	0Years	Female								01/01/2025 10:33
32	31	500573501	0106234400	GLUC	101	01/01/2025 10:29	logapriya		Male								01/01/2025 10:49
33	32	500573502	0106234400	UA	3.6	01/01/2025 10:36	logapiya		Male								01/01/2025 10:50
34	33	500573502	0106234400	SGPT	23	01/01/2025 10:36	logapiya		Male								01/01/2025 10:52
35	34	500573502	0106234400	ALB	3.97	01/01/2025 10:36	logapiya		Male								01/01/2025 10:53
36	35	500573502	0106234400	BILL-T	0.28	01/01/2025 10:36	logapiya		Male								01/01/2025 10:51
37	36	500573502	0106234400	TP	5.29	01/01/2025 10:36	logapiya		Male								01/01/2025 10:53
38	37	500573502	0106234400	TGL	231	01/01/2025 10:36	logapiya		Male								01/01/2025 10:51
Data

Sheet2(Report)

Sample Test Details TDM.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
1	Sl. No.	Sample ID	Register Date	Name	Gender	Test Date	UREA	SGOT	GGT	TP	CHOL	BILL-D	ALP	BILL-T	CAL A	TGL	SGPT	CREATIN	ALB	UA	GLUC	PHOS	ACE	IRON	AMYLASE	MICRO	CKNAC	MAG	LDH	CKMB	ZINC-CO
2	1	0106233900	01/01/2025 08:57	NithishKumar	Male	01/01/2025 09:13	UREA	SGOT	GGT	TP	CHOL	BILL-D	ALP	BILL-T	CAL A	TGL	SGPT	CREATIN	ALB	UA	GLUC
3	2	0106234100	01/01/2025 08:57	Maharaja	Male	01/01/2025 09:21	UREA				CHOL				CAL A	TGL		CREATIN		UA	GLUC	PHOS
4	3	0106234000	01/01/2025 08:58	VetrivelS	Male	01/01/2025 09:19					CHOL					TGL		CREATIN			GLUC
5	4	0106234200	01/01/2025 09:59	AnandKumarV	Male	01/01/2025 10:13															GLUC
6	5	0500573600	01/01/2025 10:19	John	Male	01/01/2025 10:34															GLUC
7	6	0500573500	01/01/2025 10:19	Pooranima	Female	01/01/2025 10:33															GLUC
8	7	0106234400	01/01/2025 10:29	logapriya	Male	01/01/2025 10:49	UREA	SGOT		TP	CHOL	BILL-D	ALP	BILL-T	CAL A	TGL	SGPT	CREATIN	ALB	UA	GLUC
9	8	0106234104	01/01/2025 11:27	Maharaja	Male	01/01/2025 11:41															GLUC
10	9	0106234004	01/01/2025 11:27	VetrivelS	Male	01/01/2025 11:40															GLUC
11	10	0500573604	01/01/2025 12:00	john	Male	01/01/2025 12:15															GLUC
12	11	0500573504	01/01/2025 12:01	pooranima	Male	01/01/2025 12:15															GLUC
13	12	0106234204	01/01/2025 12:02	anandkumar	Male	01/01/2025 12:15															GLUC
14	13	0106235600	01/01/2025 12:41	AbdulAlphaf	Male	01/01/2025 12:54	UREA	SGOT	GGT	TP		BILL-D	ALP	BILL-T			SGPT	CREATIN	ALB
Report

Cell Formulas
Range	Formula
A2:A14	A2	=IF(LEN(B2)>0,SUM(A1)+1,"")
B2:B3	B2	=IFERROR(INDEX(Data!$C$2:$C$10000, MATCH(0, COUNTIF($B$1:B1, Data!$C$2:$C$10000), 0)), "")
C2:C14	C2	=IFERROR(VLOOKUP(B2, Data!$C:$Q, 4, 0),"")
D2:D14	D2	=IFERROR(VLOOKUP(B2,Data!$C$2:$Q$10000,5,0),"")
E2:E14	E2	=IFERROR(VLOOKUP(B2,Data!$C$2:$Q$10000,7,0),"")
F2:F14	F2	=IFERROR(VLOOKUP(B2, Data!$C$2:$Q$10000, 15, 0), "")
G2:G14	G2	=IF(COUNTIFS(Data!$C:$C, $B2, Data!$D:$D, G$1) > 0, G$1, "")
H2:AE14	H2	=IF(COUNTIFS(Data!$C$2:$C$10000, $B2, Data!$D$2:$D$10000, H$1) > 0, H$1, "")
B4:B14	B4	=IFERROR(INDEX(Data!C4:C962, MATCH(0, COUNTIF($B$1:B3, Data!C4:C962), 0)), "")
Press CTRL+SHIFT+ENTER to enter array formulas.

Named Ranges
Name	Refers To	Cells
_FilterDatabase	=Report!$A$1:$AE$1128	A2

Help with a VBA Code to generate report would be of great help to me. My database runs to numerous rows and excel formula takes too much time to process the data.

Thanks in advance
Subash D

 

[dsubash]

I believe that some versions of excel are smart enough to workout the last row, otherwise it gets a bit messy
You can create a named range which shrinks and grows accordingly but it would use volatile functions which need recalculating each time so it will diminish your speed accordingly
Using a whole column reference like C:C is definitely very slow
Another option is to convert your original data to a table and update your formulas accordingly and this will shrink and grow automatically

Thanks for your immediate response, will surely check the table option too.

 

[jimrward]

What version of excel are you using
Take a look at dynamic defined range it uses offset and counta

 

[dsubash]

What version of excel are you using
Take a look at dynamic defined range it uses offset and counta

sorry for the late reply. I am using Excel 2019 professional

 

[bebo021999]

This is VBA code:

Option Explicit
Sub report()
Dim lr&, lc&, i&, j&, rng, res(), cell As Range, s As String, st
Dim dic As Object, key
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
    lr = .Cells(Rows.Count, "C").End(xlUp).Row ' last row
    rng = .Range("C2:Q" & lr).Value
    For i = 1 To UBound(rng)
        If Not dic.exists(rng(i, 1)) Then
            dic.Add rng(i, 1), rng(i, 4) & "|" & rng(i, 5) & "|" & rng(i, 7) & "|" & rng(i, 15) & "|" & rng(i, 2)
        Else
            dic(rng(i, 1)) = dic(rng(i, 1)) & "|" & rng(i, 2)
        End If
    Next
End With
Sheets("Report").Activate
i = 0: lc = Cells(1, Columns.Count).End(xlToLeft).Column ' last column
ReDim res(1 To dic.Count, 1 To lc)
rng = Range("A1", Cells(1, lc)).Value
For Each key In dic.keys
    st = Split(dic(key), "|"): i = i + 1: res(i, 1) = i: res(i, 2) = key
    res(i, 3) = st(0): res(i, 4) = st(1): res(i, 5) = st(2): res(i, 6) = st(3)
    For j = 7 To UBound(rng, 2)
        If InStr(1, dic(key), "|" & rng(1, j)) Then res(i, j) = rng(1, j)
    Next
Next
With Range("A2")
    .Resize(10000, 1000).ClearContents
    .Resize(dic.Count, lc).Value = res
End With
Set dic = Nothing
End Sub

Sample spreadsheet here

Book1.xlsm

drive.google.com

 

[Fuji]

dsubash​

If you want the code to populate the header in "report" then

Sub test()
    Dim a, i&, ii&, temp, dic(1) As Object
    Set dic(0) = CreateObject("Scripting.Dictionary")
    Set dic(1) = CreateObject("Scripting.Dictionary")
    With Sheets("data").[a1].CurrentRegion
        a = Application.Index(.Value2, Evaluate("row(1:" & .Rows.Count & ")"), [{4,3,17,7,9,6}])
        a(1, 1) = "Sl. No.": ReDim Preserve a(1 To UBound(a, 1), 1 To 1000)
    End With
    For i = 2 To UBound(a, 1)
        If dic(1)(a(i, 1)) = Empty Then
            dic(1)(a(i, 1)) = dic(1).Count + 6
            a(1, dic(1)(a(i, 1))) = a(i, 1)
        End If
        temp = a(i, 1)
        If dic(0)(a(i, 2)) = Empty Then
            dic(0)(a(i, 2)) = dic(0).Count + 1
            a(dic(0)(a(i, 2)), 1) = dic(0).Count
            For ii = 2 To 6
                a(dic(0)(a(i, 2)), ii) = a(i, ii)
            Next
        End If
        a(dic(0)(a(i, 2)), dic(1)(temp)) = temp
    Next
    With Sheets("report").[a1].CurrentRegion
        .ClearContents
        With .Resize(dic(0).Count + 1, dic(1).Count + 6)
            .Value = a
            .Rows(1).Font.Bold = True
        End With
        .Parent.Activate
    End With
End Sub

​

 

[dsubash]

dsubash​

If you want the code to populate the header in "report" then

Sub test()
    Dim a, i&, ii&, temp, dic(1) As Object
    Set dic(0) = CreateObject("Scripting.Dictionary")
    Set dic(1) = CreateObject("Scripting.Dictionary")
    With Sheets("data").[a1].CurrentRegion
        a = Application.Index(.Value2, Evaluate("row(1:" & .Rows.Count & ")"), [{4,3,17,7,9,6}])
        a(1, 1) = "Sl. No.": ReDim Preserve a(1 To UBound(a, 1), 1 To 1000)
    End With
    For i = 2 To UBound(a, 1)
        If dic(1)(a(i, 1)) = Empty Then
            dic(1)(a(i, 1)) = dic(1).Count + 6
            a(1, dic(1)(a(i, 1))) = a(i, 1)
        End If
        temp = a(i, 1)
        If dic(0)(a(i, 2)) = Empty Then
            dic(0)(a(i, 2)) = dic(0).Count + 1
            a(dic(0)(a(i, 2)), 1) = dic(0).Count
            For ii = 2 To 6
                a(dic(0)(a(i, 2)), ii) = a(i, ii)
            Next
        End If
        a(dic(0)(a(i, 2)), dic(1)(temp)) = temp
    Next
    With Sheets("report").[a1].CurrentRegion
        .ClearContents
        With .Resize(dic(0).Count + 1, dic(1).Count + 6)
            .Value = a
            .Rows(1).Font.Bold = True
        End With
        .Parent.Activate
    End With
End Sub

​

Thanks Fuji, Your code helped me save time.