More efficient code? Moving data

[Daroh]

Hello, is there anyway to make this code more efficient? It goes through over 6000 rows of data (people) and I am adding more people to the table. At present, it takes a long time to do it.

Thanks,

Sub Match_Data_and Replace()



Dim Data As Worksheet

Dim List As Worksheet

Set Data = ThisWorkbook.Sheets("Patient_Data") ' Raw Data

Set List = ThisWorkbook.Sheets("Wrk_List") ' Search Data - Wrk_List



Dim dArray() As String

Dim lArray() As String



ReDim Preserve dArray(1 To Data.Range("A" & Rows.Count).End(xlUp).Row, 1 To 34)

ReDim Preserve lArray(1 To List.Range("A" & Rows.Count).End(xlUp).Row, 1 To 34)



For a = 1 To Data.Range("A" & Rows.Count).End(xlUp).Row

For b = 1 To 34

dArray(a, b) = Data.Cells(a, b)

Next b

Next a



For a = 1 To List.Range("A" & Rows.Count).End(xlUp).Row

For b = 1 To 34

lArray(a, b) = List.Cells(a, b)

Next b

Next a



Dim MRN As String, lName As String

For a = 2 To UBound(lArray)

MRN = lArray(a, 1)

lName = lArray(a, 2)





For b = 2 To UBound(dArray)

If dArray(b, 1) = MRN And dArray(b, 4) = lName Then



dArray(b, 3) = lArray(a, 3) ' f_Name

dArray(b, 4) = lArray(a, 6)

dArray(b, 6) = lArray(a, 7) ' Phone

dArray(b, 7) = lArray(a, 5)

dArray(b, 36) = lArray(a, 13)

dArray(b, 37) = lArray(a, 14)

dArray(b, 38) = lArray(a, 15)

dArray(b, 39) = lArray(a, 16)

dArray(b, 40) = lArray(a, 17)

dArray(b, 41) = lArray(a, 18)





Exit For

End If

Next b

Next a



'Transfer data back

For a = 2 To UBound(dArray)

For b = 2 To 34

Data.Cells(a, b).Value = dArray(a, b)

Next b

Next a



End Sub

 

[mumps]

Instead of looping through the worksheet cells in column A of both sheets, assign the ranges to an array and then loop through the array. For example, instead of:

For a = 1 To Data.Range("A" & Rows.Count).End(xlUp).Row

try:

Dim vData As Variant, r As Long, c As Long
vData = Data.Range("A2", Data.Range("A" & Rows.Count).End(xlUp)).Value
For r = LBound(vData) To UBound(vData)
    For c = LBound(vData, 2) To UBound(vData, 2)
        dArray(r, c) = Data.Cells(r, c)
    Next c
Next r

The "r'" loops through the rows and the "c" loops through the columns. You could the same for the List sheet.

 

[Daroh]

Instead of looping through the worksheet cells in column A of both sheets, assign the ranges to an array and then loop through the array. For example, instead of:

For a = 1 To Data.Range("A" & Rows.Count).End(xlUp).Row

try:

Dim vData As Variant, r As Long, c As Long
vData = Data.Range("A2", Data.Range("A" & Rows.Count).End(xlUp)).Value
For r = LBound(vData) To UBound(vData)
    For c = LBound(vData, 2) To UBound(vData, 2)
        dArray(r, c) = Data.Cells(r, c)
    Next c
Next r

The "r'" loops through the rows and the "c" loops through the columns. You could the same for the List sheet.

Thanks for the response, should the code look like the below? to get the same results as before ?

Sub Replace_Data()

Dim Data As Worksheet, List As Worksheet, vList As Variant, rl As Long, cl As Long, MRN As String, lName As String, vData As Variant, r As Long, c As Long
Set Data = ThisWorkbook.Sheets("Data") ' Raw Data
List = ThisWorkbook.Sheets("List") ' Search Data - Wrk_List

Dim dArray() As String, lArray() As String
ReDim Preserve dArray(1 To Data.Range("A" & Rows.Count).End(xlUp).Row, 1 To 41)
ReDim Preserve lArray(1 To List.Range("A" & Rows.Count).End(xlUp).Row, 1 To 41)

vData = Data.Range("A2", Data.Range("A" & Rows.Count).End(xlUp)).Value
For r = LBound(vData) To UBound(vData)
    For c = LBound(vData, 2) To UBound(vData, 2)
        dArray(r, c) = Data.Cells(r, c)
    Next c
Next r

vList = List.Range("A2", List.Range("A" & Rows.Count).End(xlUp)).Value
For rl = LBound(vList) To UBound(vList)
    For cl = LBound(vList, 2) To UBound(vList, 2)
        lArray(rl, cl) = List.Cells(rl, cl)
    Next cl
Next rl

For a = 2 To UBound(lArray)
MRN = lArray(a, 1)
lName = lArray(a, 2)

'For b = 2 To UBound(dArray)
If dArray(r, 1) = MRN And dArray(r, 4) = lName Then
dArray(r, 3) = lArray(rl, 3) ' f_Name
dArray(r, 4) = lArray(rl, 6)
                Exit For
            End If
        Next rl
    Next r

'Transfer data back
For a = 2 To UBound(dArray)
For b = 2 To 41
Data.Cells(r, c).Value = dArray(rl, cl)
    Next b
        Next a
End Sub

 

[mumps]

Could you please use the XL2BB addin to post screen shots (not pictures) of your two sheets and explain in detail what you want to do using a few examples from your data.

 

[Daroh]

This is the sheet with all the people entered on it and it has over 6000 so far and it is growing. The 'Date of review' and 'Comments' will be entered on a seprate day and the data should be pulled from sheet("List"). If the MRN is the same on both Sheet("List") and Sheet("Data"). The code is ran and the data from Sheet("List") is transfered to Sheet("Data") in the that the MRN is matched.

Sheet("Data")

Book1
	A	B	C	D	E	F	G
1	MRN	First Name	Second Name	Phione	Gender	Date Of review	Comments
2	123	John	SecondName1	111111	m
3	654	Peter	SecondName2	22222	f
4	789	Simon	SecondName3	33333	m
5	3322	Marcus	SecondName4	4444	f
6	5588	Kevin	SecondName5	5555	m
7	6688	JoJo	SecondName6	6666	f
Data

Sheet("List") is a work list of people to review on a certain day.

Book1
	A	B	C	D	E	F	G
1	MRN	First Name	Second Name	Phione	Gender	Date of Review	Comments
2	123	John	SecondName1			on the day of review	data will be entered during review and once the day is finished the code should transfer the data to Sheet(Data) on the same row as the matched MRN.
3
List

 

[mumps]

Thank you for the sheets. If I were to suggest a macro based on the data you posted, most likely it will not work with your actual file. Your code indicates that you have 34 columns of data while the data you posted has only seven columns. In order to get a working macro, I would need sheets that are exactly representative of your actual data. Please don't leave any cells blank unless they are also blank in your actual file. Also, a few more rows of data in the List sheet would be helpful. Could you re-post the two sheets that have data in exactly the same cells, rows and columns as your actual file? Also clarify if the entire row of data should be transferred or only data in certain columns should be transferred. If not the entire row, please indicate which columns.

 

[Daroh]

Could you please use the XL2BB addin to post screen shots (not pictures) of your two sheets and explain in detail what you want to do using a few examples from your data.

Thank you for the sheets. If I were to suggest a macro based on the data you posted, most likely it will not work with your actual file. Your code indicates that you have 34 columns of data while the data you posted has only seven columns. In order to get a working macro, I would need sheets that are exactly representative of your actual data. Please don't leave any cells blank unless they are also blank in your actual file. Also, a few more rows of data in the List sheet would be helpful. Could you re-post the two sheets that have data in exactly the same cells, rows and columns as your actual file? Also clarify if the entire row of data should be transferred or only data in certain columns should be transferred. If not the entire row, please indicate which columns.

It should be only certain columns. It would be brilliant if the data was entered in the headers if they matched. For example, Date Range (New) would be entered from Sheet("List") to Sheet("Data") if the MRN matched the data would be copied to the correct column header "Date Range (New)".

Sheet("Data") this is the complete list of people and raw data.

CPAP MrExcel.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	AF	AG	AH	AI	AJ	AK	AL	AM
1	MRN	Last Name	First Name	Gender	Address	Contact Number	DOB	Referral	Height m	Weight Kg	BMI	Ep Score	Stop/Bang	Driver for Work	AHI	PLM index	Arousal Index	RDI	Notes: Cancelled tests/ Contacted for cancellation	Date of test	Date of repeat test	Date of CPAP Review Clinic	Medical Card	Provider	Model	Treatment Mode	Pressure	Mask Type	Compliant	Adherent	Medical Card	Date Range (New)	AHI (New)	%Data USED (NEW)	% Days Used 4>hrs (NEW)	Average hrs of use (NEW)	ESS (NEW)	GP	GP Address
2	123	Last_Name1	First_Name	f	Adress_1	123456789	01/01/2024	Dr 1	1.61	98.2	37.88	2	5	no	65	3	7	65		25.01.24	This Column might be empty or have text		yes	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	Entered on day	Entered on day	Entered on day	Entered on day	Entered on day	Entered on day	GP 1	GP_Address_1
3	456	Last_Name2	First_Name	m	Adress_2	123456789	02/01/2024	Dr 2	1.73	83	27.73	2	6	Yes	32	5	8	65		25.01.25			no	Direct Medical														GP 2	GP_Address_2
4	789	Last_Name3	First_Name	m	Adress_3	123456789	03/01/2024	Dr 1	1.81	107		2	7	No	77	2	38	77		25.01.26			yes	Direct Medical							Yes							GP 3	GP_Address_3
5	321	Last_Name4	First_Name	m	Adress_4	123456789	04/01/2024	Dr 2	1.73	81	27.06	2	3	n	14	3	15	15		25.01.27		16/01/2018	no		Devilbiss Sleep Cube	fixed	7.5cmH2O	nasal	y	n								GP 4	GP_Address_4
6	654	Last_Name5	First_Name	m	Adress_5	123456789	05/01/2024	Dr 1	1.69	113.7	39.81	2	2	n	13	24	7	13		25.01.28			yes	Direct Medical							No							GP 5	GP_Address_5
7	987	Last_Name6	First_Name	m	Adress_6	123456789	06/01/2024	Dr 2	1.84	131	39.00	2	6	no	27	68	9	1		25.01.29			no	Direct Medical														GP 6	GP_Address_6
8	7788	Last_Name7	First_Name	m	Adress_7	123456789	07/01/2024	Dr 1	1.81	106	32.40	2	6	n	46	15	40	46		25.01.30			yes								Yes							GP 7	GP_Address_7
9	9988	Last_Name8	First_Name	F	Adress_8	123456789	08/01/2024	Dr 2	1.7	160		2	6	no	98	16	42	98		25.01.31		19/05/2022	no	Direct Medical	E20A	auto	4-20cmH2O	nasal										GP 8	GP_Address_8
10	11225	Last_Name9	First_Name	f	Adress_9	123456789	09/01/2024	Dr 1	1.67	107	38.37	2	6	yes	15	5	10	2		25.01.32	10/01/2023		yes	Direct Medical							No							GP 9	GP_Address_9
Data

Cell Formulas
Range	Formula
K10,K5:K6,K2:K3	K2	=(J2/(I2*I2))

Sheet("List"), this is the work list for a given day.

CPAP MrExcel.xlsx
	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1	Phone	AHI (ORG)	Arousal Index (ORG)	PLM index (ORG)	ESS (ORG)	Date Range (New)	AHI (New)	%Data USED (NEW)	% Days Used 4>hrs (NEW)	Average hrs of use (NEW)	ESS (NEW)	Medical Card:	Comment	GP Address	GP Name	Commerical Driver	Medical Card
2	123456789	65	65	3	7	Entered on day	Entered on day	Entered on day	Entered on day	Entered on day	Entered on day	yes	Entered on Day	GP 1	GP_Address_1	no
List

 

[Daroh]

It should be only certain columns. It would be brilliant if the data was entered in the headers if they matched. For example, Date Range (New) would be entered from Sheet("List") to Sheet("Data") if the MRN matched the data would be copied to the correct column header "Date Range (New)".

Sheet("Data") this is the complete list of people and raw data.

CPAP MrExcel.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	AF	AG	AH	AI	AJ	AK	AL	AM
1	MRN	Last Name	First Name	Gender	Address	Contact Number	DOB	Referral	Height m	Weight Kg	BMI	Ep Score	Stop/Bang	Driver for Work	AHI	PLM index	Arousal Index	RDI	Notes: Cancelled tests/ Contacted for cancellation	Date of test	Date of repeat test	Date of CPAP Review Clinic	Medical Card	Provider	Model	Treatment Mode	Pressure	Mask Type	Compliant	Adherent	Medical Card	Date Range (New)	AHI (New)	%Data USED (NEW)	% Days Used 4>hrs (NEW)	Average hrs of use (NEW)	ESS (NEW)	GP	GP Address
2	123	Last_Name1	First_Name	f	Adress_1	123456789	01/01/2024	Dr 1	1.61	98.2	37.88	2	5	no	65	3	7	65		25.01.24	This Column might be empty or have text		yes	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	This Column might be empty or have text	Entered on day	Entered on day	Entered on day	Entered on day	Entered on day	Entered on day	GP 1	GP_Address_1
3	456	Last_Name2	First_Name	m	Adress_2	123456789	02/01/2024	Dr 2	1.73	83	27.73	2	6	Yes	32	5	8	65		25.01.25			no	Direct Medical														GP 2	GP_Address_2
4	789	Last_Name3	First_Name	m	Adress_3	123456789	03/01/2024	Dr 1	1.81	107		2	7	No	77	2	38	77		25.01.26			yes	Direct Medical							Yes							GP 3	GP_Address_3
5	321	Last_Name4	First_Name	m	Adress_4	123456789	04/01/2024	Dr 2	1.73	81	27.06	2	3	n	14	3	15	15		25.01.27		16/01/2018	no		Devilbiss Sleep Cube	fixed	7.5cmH2O	nasal	y	n								GP 4	GP_Address_4
6	654	Last_Name5	First_Name	m	Adress_5	123456789	05/01/2024	Dr 1	1.69	113.7	39.81	2	2	n	13	24	7	13		25.01.28			yes	Direct Medical							No							GP 5	GP_Address_5
7	987	Last_Name6	First_Name	m	Adress_6	123456789	06/01/2024	Dr 2	1.84	131	39.00	2	6	no	27	68	9	1		25.01.29			no	Direct Medical														GP 6	GP_Address_6
8	7788	Last_Name7	First_Name	m	Adress_7	123456789	07/01/2024	Dr 1	1.81	106	32.40	2	6	n	46	15	40	46		25.01.30			yes								Yes							GP 7	GP_Address_7
9	9988	Last_Name8	First_Name	F	Adress_8	123456789	08/01/2024	Dr 2	1.7	160		2	6	no	98	16	42	98		25.01.31		19/05/2022	no	Direct Medical	E20A	auto	4-20cmH2O	nasal										GP 8	GP_Address_8
10	11225	Last_Name9	First_Name	f	Adress_9	123456789	09/01/2024	Dr 1	1.67	107	38.37	2	6	yes	15	5	10	2		25.01.32	10/01/2023		yes	Direct Medical							No							GP 9	GP_Address_9
Data

Cell Formulas
Range	Formula
K10,K5:K6,K2:K3	K2	=(J2/(I2*I2))

Sheet("List"), this is the work list for a given day.

CPAP MrExcel.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1	MRN	Date Preformed	First_Name	Second_Name	DOB	Gender	Phone	AHI (ORG)	Arousal Index (ORG)	PLM index (ORG)	ESS (ORG)	Date Range (New)	AHI (New)	%Data USED (NEW)	% Days Used 4>hrs (NEW)	Average hrs of use (NEW)	ESS (NEW)	Medical Card:	Comment	GP Address	GP Name	Commerical Driver	Medical Card
2	123	25.01.24	First_Name	Last_Name2	01/01/2024	f	123456789	65	65	3	7	Entered on day	Entered on day	Entered on day	Entered on day	Entered on day	Entered on day	yes	Entered on Day	GP 1	GP_Address_1	no
3
4
5
6
List

 

[mumps]

It should be only certain columns.

Which columns?

 

[Daroh]

Which columns?

Sheet("List") M to S should be copied to Sheet("Data") to AF to AK. Is it possible to copy the data based on the MRN (first column) and headers. The headers are the same on both sheets.