Denin Srmic
New Member
- Joined
- Apr 28, 2020
- Messages
- 19
- Office Version
- 365
- Platform
- Windows
Hello,
I have two workbooks Master and Search, and within workbooks there is one spreadsheet in each book. Master book contains over 220 000 rows, whereas Search book has 35 000 rows. Both Sheets have the same number of Columns (216) ordered the same way and with the same Header names.
My task is to pull all the data from the Search Sheet based on condition matching Name, Surname, Date of Birth, Screening Day, and Event in both Sheets, into Master spreadsheet. I do not need entire row to be pulled into Master Sheet but only data starting from column BX to HH NOT entire row.
I have completed the code (please see bellow) that would do the job, but it is tremendously slow for vast amounts of data.
I would appreciate help of VBA Wizards here if they could help in creating a code that would do this job much faster, as this take too long.
Any suggestions, improvements, or critiques on my code are very welcome.
Many Thanks
I have two workbooks Master and Search, and within workbooks there is one spreadsheet in each book. Master book contains over 220 000 rows, whereas Search book has 35 000 rows. Both Sheets have the same number of Columns (216) ordered the same way and with the same Header names.
My task is to pull all the data from the Search Sheet based on condition matching Name, Surname, Date of Birth, Screening Day, and Event in both Sheets, into Master spreadsheet. I do not need entire row to be pulled into Master Sheet but only data starting from column BX to HH NOT entire row.
I have completed the code (please see bellow) that would do the job, but it is tremendously slow for vast amounts of data.
I would appreciate help of VBA Wizards here if they could help in creating a code that would do this job much faster, as this take too long.
Any suggestions, improvements, or critiques on my code are very welcome.
Many Thanks
VBA Code:
Option Explicit
Sub MergeData()
'We want to merge data from our ThisWorkbook(Search Sheet) with MasterDb(Master Sheet) based on multiple conditions
Dim oThisWb As Workbook
Dim oThisWs As Worksheet
Dim oMasterWb As Workbook
Dim oMasterWs As Worksheet
Dim rT As Range 'whole Range in Search Wb
Dim rThdr As Range 'Header Range in Search Wb
Dim rM As Range 'whole Range in Search Wb
Dim rMhdr As Range 'Header Range in Search Wb
Dim lr As Long
Dim lc As Long
Dim lrT As Long
Dim lcT As Long
Dim iM As Long
Dim iT As Long
Dim lCounter As Long
Dim sMasterDbFolderPath As String
Dim sFirstName As String
Dim sSurname As String
Dim sPdetailsVenue As String
Dim dDateOfScreening As Date
Dim dPdetailsDOB As Date
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
sMasterDbFolderPath = Environ("UserProfile") & "\Desktop\H\Master DatabaseFinal25112022.xlsx"
If Dir(sMasterDbFolderPath) = vbNullString Then
MsgBox Prompt:="Folder Path for Master Db does not exist!", Buttons:=vbCritical, Title:="Folder Does not exist!"
Exit Sub
End If
Set oThisWb = ThisWorkbook
Set oThisWs = oThisWb.Worksheets("HData")
With oThisWs
.Activate
lrT = .Cells.Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
lcT = .Cells.Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
Set rThdr = .Range(Range("A1"), .Cells(1, lcT))
Set rT = .Range("A1").Resize(lrT, lcT)
End With
On Error Resume Next
Set oMasterWb = Workbooks.Open(sMasterDbFolderPath)
On Error GoTo 0
Set oMasterWs = oMasterWb.Worksheets("RevisedMasterDB")
With oMasterWs
lr = .Cells.Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
lc = .Cells.Find(What:="*", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
Set rMhdr = .Range(Range("A1"), .Cells(1, lc))
Set rM = .Range("A1").Resize(lr, lc)
End With
'first loop read name and surname and other conditions in H's Spreadsheet
oThisWs.Activate
For iT = 2 To lrT
sFirstName = oThisWs.Range("F" & iT).Value
sSurname = oThisWs.Range("G" & iT).Value
sPdetailsVenue = oThisWs.Range("C" & iT).Value
dDateOfScreening = oThisWs.Range("A" & iT).Value
dPdetailsDOB = oThisWs.Range("M" & iT).Value
'second loop to search for names, firstname and surname and other conditions in master Db and performe extraction
oMasterWs.Activate
For iM = 2 To lr
On Error Resume Next
If oMasterWs.Range("F" & iM).Value = sFirstName And oMasterWs.Range("G" & iM).Value = sSurname _
And oMasterWs.Range("C" & iM).Value = sPdetailsVenue And oMasterWs.Range("A" & iM).Value = dDateOfScreening _
And oMasterWs.Range("M" & iM).Value = dPdetailsDOB Then
On Error GoTo 0
oThisWs.Activate
oThisWs.Range(Cells(iT, "BX"), Cells(iT, "HH")).Copy
oMasterWs.Activate
oMasterWs.Range(Cells(iM, "BX"), Cells(iM, "HH")).Select
oMasterWs.Range(Cells(iM, "BX"), Cells(iM, "HH")).PasteSpecial Paste:=xlPasteValues
oMasterWs.Range("O" & iM).Value = oThisWs.Range("O" & iT).Value
oMasterWs.Range("P" & iM).Value = oThisWs.Range("P" & iT).Value
oMasterWs.Range(Cells(iM, "BX"), Cells(iM, "HH")).Interior.Color = vbYellow
End If
Next iM
Application.CutCopyMode = False
lCounter = lCounter + 1
Debug.Print lCounter
Next iT
oMasterWs.Activate
oMasterWb.Save
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set rT = Nothing
Set rThdr = Nothing
Set rM = Nothing
Set rMhdr = Nothing
lr = 0
lc = 0
lrT = 0
lcT = 0
iM = 0
iT = 0
lCounter = 0
sMasterDbFolderPath = vbNullString
sFirstName = vbNullString
sSurname = vbNullString
sPdetailsVenue = vbNullString
dDateOfScreening = 0
dPdetailsDOB = 0
End Sub
