Very new to VBA coding. I inserted a Text Box (Active Control X) in my worksheet. Wrote a code to import data from MS Access database and save that data to an array. Later I am trying to print that array in the text box for user to see. but everytime my code enters the nested part of For loop, the running iteration of sub jumps back to the start of the code. Code than runs for multiple times make multiple SQL queries and excel crashes. I am not sure why code is jumping back to start of the sub?
Private Sub TextBox1_Change()
Dim sQuery As String
Dim ReturnData() As Variant
'Clear existing data in statuses area
Dim rngClearArea As Range
Dim wsFleetio As Worksheet
Set wsFleetio = ThisWorkbook.Worksheets("Test")
Dim Farm As String
Farm = wsFleetio.Range("B1").Value
'Set rngClearArea = FindTag(wsFleetio, "$Vehicle Status", 2, 0).Resize(1000, 4)
'rngClearArea.ClearContents
'Build query
sQuery = "SELECT [KillDate], [FarmName], [LoadType] FROM Loads WHERE ([FarmName] = '" & Farm & "' AND [KillDate] >= DateAdd('yyyy', -1, Date()))"
ReturnData = GetMerlinData(sQuery)
Dim leng As Integer
leng = UBound(ReturnData, 2)
Dim FarmData(500, 2) As Variant
Dim m As Integer
For m = 0 To UBound(ReturnData, 2)
FarmData(m, 0) = ReturnData(0, m)
FarmData(m, 1) = ReturnData(1, m)
FarmData(m, 2) = ReturnData(2, m)
Next
Dim i As Long, j As Long
For i = 0 To UBound(ReturnData, 2)
For j = 0 To 2
TextBox1.Text = TextBox1.Text & FarmData(i, j) & "---"
Next j
TextBox1.Text = TextBox1.Text & vbCrLf
Next i
End Sub
After running the first iteration of j, code jumps back to start of the code. I want it to run normally but not sure what the error is
Add a second TextBox, TextBox2 and use it in the loop: TextBox2.Text = TextBox2.Text & ...
I have built an Excel Workbook that is intended for evaluation of an organization as a whole and then evaluation of each of several sites for that organization. There is an initial assessment and then an on-site assessment for the organization, and for each facility. Depending on the organization, the number of facilities will vary. There is a first "Configuration" tab where the user of the workbook enters (or copies and pastes) the list of facilities and determines which facilities are to be included in the evaluation.
The second and third worksheets are the assessment for the organization as a whole, and the fourth and fifth worksheets are template assessment forms for the facilities.
Once the list of facilities is entered, the user clicks on a button labeled "Create Facility Tabs" that steps through the facility list and creates the needed worksheets for each facility.
If the list is fresh (starting from its initial form), then the template worksheets are renamed for the first facility and new worksheets are created for the remainder.
If there are already worksheets identified, the software checks each facility to see if its page already exists, and only creates additional worksheets for newly added facilities.
When additional worksheets are needed, the code first counts the number of additional worksheets that are needed (two for each facility), creates those worksheets, and then steps through them copying the template contents onto the forms and the change code for the worksheets into the worksheet's module.
The software works perfectly over and over again when I have the VBA window open. It does everything it is supposed to do. However, when I close the VBA window, the code creates all the worksheets, copies everything into the first worksheet, and then raises a Subscript Out of Range error. Any ideas what I am doing wrong?
Here is the code:
Public Sub CreateFacilities()
Dim row As Long
Dim facility_name As String
Dim facility_list As String
Dim facilities As Variant
Dim include As Boolean
Dim ws_init As Worksheet
Dim ws_fac As Worksheet
Dim ws_new_init As Worksheet
Dim ws_new_fac As Worksheet
Dim ws_config As Worksheet
Dim facility_count As Long
Dim tabs_to_create As Long
Dim fac_initial_range As Range
Dim fac_initial_address As String
Dim fac_onsite_range As Range
Dim fac_onsite_address As String
Dim message As String
Dim title As String
Dim answer As Variant
Dim code_line As String
Dim b_width As Long
Dim c_width As Long
Dim counter As Long
Dim init_sheet_number As Long
Dim fac_sheet_number As Long
Dim tab_count As Long
title = "Creating Facility Tabs"
message = "Before you execute this function you should" & vbCrLf & "add any study-specific questions to the" & vbCrLf
message = message & "Initial Assessment - Facility1 and" & vbCrLf & "On-Site Assessment - Facility1 tabs so" & vbCrLf
message = message & "they will be included on the created facility tabs" & vbCrLf & vbCrLf
message = message & "Do you wish to continue?"
answer = MsgBox(message, vbYesNo + vbQuestion, title)
If answer = vbNo Then
Exit Sub
End If
Set ws_config = ThisWorkbook.Sheets("Configuration")
Set ws_init = ThisWorkbook.Sheets(4)
Set ws_fac = ThisWorkbook.Sheets(5)
b_width = ws_init.Columns("B").ColumnWidth
c_width = ws_init.Columns("C").ColumnWidth
Set fac_initial_range = ws_init.Range("A1:C" & Trim(Str(FindLastRow(ws_init))))
Set fac_onsite_range = ws_fac.Range("A1:C" & Trim(Str(FindLastRow(ws_fac))))
fac_initial_address = fac_initial_range.address
fac_onsite_address = fac_onsite_range.address
code_line = ThisWorkbook.VBProject.VBComponents("Module1").CodeModule.Lines(1, 50) 'get code for each new worksheet
facility_list = "" 'get list of facilities
facility_count = 0
For row = 4 To 54
facility_name = ThisWorkbook.Sheets("Configuration").cells(row, 2).value
include = ThisWorkbook.Sheets("Configuration").cells(row, 4).value
If facility_name = "" Then 'reached the end of the list
Exit For
Else:
If include Then 'the Do Assessment column is marked TRUE
If Not WorksheetExists(facility_name) Then 'the tabs for this facility do not already exist
facility_list = facility_list & facility_name & ","
End If
End If
End If
Next row
facility_list = Left(facility_list, Len(facility_list) - 1) 'remove trailing comma
If facility_list = "" Then 'no new facilities were added to the list
MsgBox "There were no facilties specified for inclusion"
Exit Sub
End If
facilities = Split(facility_list, ",") 'there is a list of facilities to add
facility_count = UBound(facilities) + 1
If ActiveWorkbook.Sheets.Count = 5 Then 'no facility tabs have been added
If facility_count = 1 Then 'there is only one facility - no tabs need to be added
tabs_to_create = 0
facility_name = facilities(0)
ws_init.Name = CreateInitialTabName(facility_name)
ws_fac.Name = CreateOnSiteTabName(facility_name)
Else:
tabs_to_create = (facility_count - 1) * 2
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count), Count:=tabs_to_create
For counter = LBound(facilities) To UBound(facilities)
facility_name = facilities(counter)
If counter = 0 Then 'rename the first two facility worksheets that already exist
ws_init.Name = CreateInitialTabName(facility_name)
ws_fac.Name = CreateOnSiteTabName(facility_name)
Else: 'for the rest, add worksheets and copy template content and code
init_sheet_number = ((counter - 1) * 2) + 6
fac_sheet_number = init_sheet_number + 1
Set ws_new_init = ActiveWorkbook.Sheets(init_sheet_number) 'create initial assessment sheet for facility
ws_new_init.Columns("B").ColumnWidth = b_width
ws_new_init.Columns("C").ColumnWidth = c_width
ws_new_init.Name = CreateInitialTabName(facility_name)
fac_initial_range.Copy Destination:=ws_new_init.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_init.CodeName).CodeModule.AddFromString code_line
Set ws_new_fac = ActiveWorkbook.Sheets(fac_sheet_number) 'create on-site assessment sheet for facility
ws_new_fac.Columns("B").ColumnWidth = b_width
ws_new_fac.Columns("C").ColumnWidth = c_width
ws_new_fac.Name = CreateOnSiteTabName(facility_name)
fac_onsite_range.Copy Destination:=ws_new_fac.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_fac.CodeName).CodeModule.AddFromString code_line
End If
Next counter
End If
Else: 'there are more than 5 tabs in the workbook - some were already added
tab_count = ActiveWorkbook.Sheets.Count
tabs_to_create = facility_count * 2
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(tab_count), Count:=tabs_to_create
For counter = LBound(facilities) To UBound(facilities)
facility_name = facilities(counter)
init_sheet_number = (counter * 2) + (tab_count + 1)
fac_sheet_number = init_sheet_number + 1
Set ws_new_init = ActiveWorkbook.Sheets(init_sheet_number)
Set ws_new_fac = ActiveWorkbook.Sheets(fac_sheet_number)
ws_new_init.Name = CreateInitialTabName(facility_name)
ws_new_fac.Name = CreateOnSiteTabName(facility_name)
ws_new_init.Columns("B").ColumnWidth = b_width
ws_new_fac.Columns("B").ColumnWidth = b_width
ws_new_init.Columns("C").ColumnWidth = c_width
ws_new_fac.Columns("C").ColumnWidth = c_width
fac_initial_range.Copy Destination:=ws_new_init.Range("A1")
fac_onsite_range.Copy Destination:=ws_new_fac.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_init.CodeName).CodeModule.AddFromString code_line
ThisWorkbook.VBProject.VBComponents(ws_new_fac.CodeName).CodeModule.AddFromString code_line
Next counter
End If
ws_config.Activate
MsgBox Str(facility_count) & " facilities added"
End Sub
I have code where I am accessing an xml feed for live currency data. I need to capture the price every 3 minutes, and it has to be pretty spot on, otherwise it will throw off the other calculations.
I set up a timer to run the code every 3 minutes, or whatever interval I choose.
I started noticing slippage, which was a second or two at first but has turned into 10 seconds in places. Any thoughts?
Sub xmlData()
Dim aSwitch As String: aSwitch = Sheet2.[Switch].Value
Dim aSymbol As String: aSymbol = Sheet2.[Symbol].Value
'check [switch] status
If aSwitch = "OFF" Then
MsgBox "Switch is OFF!", vbCritical, "Program Status"
Exit Sub
End If
'MsgBox "Program is ON!", vbCritical, "Program Status"
'refresh xml data
Dim iMap As XmlMap
Set iMap = ActiveWorkbook.XmlMaps(1)
iMap.DataBinding.LoadSettings "http://****.com/webservice/v1/symbols/" & aSymbol & "/quote"
iMap.DataBinding.Refresh
'dim inputs
Dim aStart As String: aStart = Sheet2.Range("c3").Text
Dim aInterval As String: aInterval = Sheet2.Range("d3").Text
Dim aStatus As String: aStatus = Sheet2.[Status].Value
'oth
Dim aSecurity As String: aSecurity = Sheet2.[Security].Value
Dim aPrice As String: aPrice = Sheet2.[Price].Value
Dim aDatetime As String: aDatetime = Sheet2.[DateTime].Value
'separate adatetime
Dim aDate As String: aDate = Mid(aDatetime, 1, 10)
Dim aTime As String: aTime = Mid(aDatetime, 12, 10)
'Time actual
Dim aTimeNow As String: aTimeNow = Format(Now(), "HH:mm:ss")
'copy xml data to table
Dim aRow As Long
aRow = Sheet2.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
Sheet2.Cells(aRow, 1).Value = aDate
Sheet2.Cells(aRow, 2).Value = aTime
Sheet2.Cells(aRow, 3).Value = aSecurity
Sheet2.Cells(aRow, 4).Value = aPrice
Sheet2.Cells(aRow, 5).Value = aTimeNow
'start timer for reload
Application.OnTime Now + TimeValue(aInterval), "xmlData"
End Sub
EDIT 160627
Is it possible the XML is not fetching right away?
Calculate the scheduled time in absolute terms, rather than as a differential from Now. (Now will always be some amount of time after the last scheduled time, so will always creep)
Sub xmlData()
Static ScheduleTime As Variant ' Statis retains value between executions
Dim aInterval As String
' other code
' ...
If ScheduleTime = 0 Then
' initialise on first execution
ScheduleTime = Now + TimeValue(aInterval)
Else
' schedule based on last scheduled time
' this assumes execution time is always less than interval
ScheduleTime = ScheduleTime + TimeValue(aInterval)
End If
Application.OnTime Now + TimeValue(aInterval), "xmlData"
End Sub
I'm having some trouble with a macro for Excel. The snippet that's giving me trouble is responsible for:
1) allowing the user to select multiple column headers, one by one
2) taking the contents of each columns, in the order of header selection, and concatenating
Here's the code:
Dim concat1() As Range
Dim rng As Variant
Dim i As Variant
Dim g As Integer
Dim metalabels() As String
Dim concated As String
Dim s As Variant
lastrow = Cells(rows.Count, "A").End(xlUp).Row
i = 0
msgselect = MsgBox("Would you like to concatonate?", vbOKCancel)
On Error GoTo Errhandler
If msgselect = vbOK Then
Do
ReDim Preserve concat1(i)
Set concat1(i) = Application.InputBox("Select the headers you would like to concatonate", Default:=ActiveCell.Address, Type:=8)
msgselect = MsgBox("Another cell?", vbOKCancel)
i = i + 1
Loop While msgselect = vbOK
i = i - 1
Errhandler:
End If
ReDim metalabels(i)
For g = 0 To i
metalabels(g) = concat1(g).Text
Next
ActiveSheet.Range("a1").End(xlToRight).Offset(0, 1).Select
ActiveCell = "Situation"
For h = 1 To lastrow - 1
For g = 0 To UBound(metalabels)
concated = concated + metalabels(g) + ": " + concat1(g).Offset(h, 0).Text + " / "
Next
ActiveCell.Offset(h, 0).Value = concated
concated = ""
Next
End Sub
The problem is here:
Set concat1(i) = Application.InputBox("Select the headers you would like to concatonate", Default:=ActiveCell.Address, Type:=8)
If the user selects "Cancel," the code crashes since the loop depends on vbOK. So, I thought I'd put in an error handler, but, as it is, I get the "object variable or with block not set" error.
As you might sense, I'm still a nube with VB. Any help is greatly appreciated.
Thanks!
Place this after your End IF
If concat1(i) Is Nothing Then Exit Sub
Did you try adding if concat1(i) = false then exit sub before incrementing i?
I have a loop that can go on for ages, although the "Enheder" worksheet only has like 10 rows, and the dataset im loadin has maybe 300 rows, it's taking a REALLY long time when I try to import.
Public Function ImportData()
Dim resultWorkbook As Workbook
Dim curWorkbook As Workbook
Dim importsheet As Worksheet
Dim debugsheet As Worksheet
Dim spgsheet As Worksheet
Dim totalposts As Integer
Dim year As String
Dim month As String
Dim week As String
Dim Hospital As String
Dim varType As String
Dim numrows As Integer
Dim Rng As Range
Dim colavg As String
Dim timer As String
Dim varKey As String
year = ImportWindow.ddYear.value
month = ImportWindow.ddMonth.value
week = "1"
varType = ImportWindow.ddType.value
Hospital = ImportWindow.txtHospital.value
Set debugsheet = ActiveWorkbook.Sheets("Data")
Set spgsheet = ActiveWorkbook.Sheets("Spørgsmål")
Set depsheet = ActiveWorkbook.Sheets("Enheder")
Set resultWorkbook = OpenWorkbook()
setResultColVars debugsheet
'set sheets
Set importsheet = resultWorkbook.Sheets("Dataset")
numrows = debugsheet.UsedRange.Rows.Count
'make sure that the enhed can be found in the importsheet, so the units can be extracted accordingly
If Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
Dim DepColumn
Dim aCell
DepColumn = importsheet.UsedRange.Find("afdeling").column
'sort importsheet to allow meaningfull row calculations
Set aCell = importsheet.UsedRange.Columns(DepColumn)
importsheet.UsedRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
Dim tempRange As Range
Dim SecColumn
Dim secRange As Range
'find row ranges for departments
Application.ScreenUpdating = False
'**Here's the loop that will go on for aaaaaages until I decide to ctrl+pause**
For Each c In depsheet.UsedRange.Columns(1).Cells
splStr = Split(c.value, "_")
If UBound(splStr) = -1 Then
ElseIf UBound(splStr) = 0 Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, DepColumn, splStr(0)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), 0, varType, False)
ElseIf UBound(splStr) = 1 And Not (importsheet.UsedRange.Find("afdeling_" & splStr(0)) Is Nothing) Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, importsheet.UsedRange.Find("afdeling_" & splStr(0)).column, splStr(1)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), splStr(1), varType, False)
End If
Next
Application.ScreenUpdating = True
' go through columns to get total scores
totalposts = totalposts + IterateColumns(importsheet.UsedRange, spgsheet, importsheet, debugsheet, year, month, week, Hospital, 0, 0, varType, True)
resultWorkbook.Close Saved = True
ResultsWindow.lblPoster.Caption = totalposts
ImportWindow.Hide
ResultsWindow.Show
Else
MsgBox "Kunne ikke finde afdelingskolonnen. Kontroller at der er er en kolonne med navnet 'afdeling' i dit datasæt"
End If
End Function
Function GetRowRange(sheetRange, column, value) As Range
'check for a valid section column
sheetRange.AutoFilterMode = False
sheetRange.UsedRange.AutoFilter Field:=column, Criteria1:=value
Set GetRowRange = sheetRange.UsedRange.SpecialCells(xlCellTypeVisible)
sheetRange.AutoFilterMode = False
End Function
'iterates through columns of a range to get the averages based on the column headers
Function IterateColumns(varRange As Range, spgsheet, importsheet, resultsheet, year, month, week, Hospital, dep, sec, varType, sortspg As Boolean)
Dim numrows
Dim totalposts
Dim usedRng
totalposts = 0
numrows = resultsheet.UsedRange.Rows.Count
Dim insert
insert = True
If Not (varRange Is Nothing) Then
' go through columns to get scores
For i = 1 To varRange.Columns.Count
Dim tempi
tempi = numrows + totalposts + 1
Set Rng = varRange.Columns(i)
With Application.WorksheetFunction
'make sure that the values can calculate
If (.CountIf(Rng, "<3") > 0) Then
colavg = .SumIf(Rng, "<3") / .CountIf(Rng, "<3")
insert = True
Else
insert = False
End If
End With
'key is the variable
varKey = importsheet.Cells(1, i)
'only add datarow if the data matches a spg, and the datarow is not actually a department
If (sortSpgs(varKey, spgsheet, sortspg)) And (insert) And Not (InStr(key, "afdeling")) Then
resultsheet.Cells(tempi, WyearCol).value = year
resultsheet.Cells(tempi, WmonthCol).value = month
resultsheet.Cells(tempi, WweekCol).value = "1"
resultsheet.Cells(tempi, WhospCol).value = "Newport Hospital"
resultsheet.Cells(tempi, WdepCol).value = "=VLOOKUP(N" & tempi & ",Enheder!$A:$B,2,0)"
resultsheet.Cells(tempi, WsecCol).value = "=IFERROR(VLOOKUP(O" & tempi & ",Enheder!$A:$B,2,0),"" "")"
resultsheet.Cells(tempi, WdepnrCol).value = dep
resultsheet.Cells(tempi, WsecnrCol).value = dep & "_" & sec
resultsheet.Cells(tempi, WjtypeCol).value = varType
resultsheet.Cells(tempi, WspgCol).value = varKey
resultsheet.Cells(tempi, WsporgCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,6,0)"
resultsheet.Cells(tempi, WtestCol).value = ""
resultsheet.Cells(tempi, Wsv1Col).value = colavg
resultsheet.Cells(tempi, Wsv2Col).value = (1 - colavg)
resultsheet.Cells(tempi, Wsv3Col).value = ""
resultsheet.Cells(tempi, WgrpCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,4,0)"
totalposts = totalposts + 1
End If
Next
End If
IterateColumns = totalposts
End Function
'Function that gets the workbook for import
Function OpenWorkbook()
Dim pathString As String
Dim resultWorkbook As Workbook
pathString = Application.GetOpenFilename(fileFilter:="All Files (*.*), *.*")
' check if it's already opened
For Each wb In Workbooks
If InStr(pathString, wb.Name) > 0 Then
Set resultWorkbook = wb
Exit For
End If
Next wb
If Not found Then
Set resultWorkbook = Workbooks.Open(pathString)
End If
Set OpenWorkbook = resultWorkbook
End Function
'find column numbers for resultsheet instead of having to do this in every insert
Function setResultColVars(rsheet)
WyearCol = rsheet.UsedRange.Find("År").column
WmonthCol = rsheet.UsedRange.Find("Måned").column
WweekCol = rsheet.UsedRange.Find("Uge").column
WhospCol = rsheet.UsedRange.Find("Hospital").column
WdepCol = rsheet.UsedRange.Find("Afdeling").column
WsecCol = rsheet.UsedRange.Find("Afsnit").column
WdepnrCol = rsheet.UsedRange.Find("Afdelingsnr").column
WsecnrCol = rsheet.UsedRange.Find("Afsnitnr").column
WjtypeCol = rsheet.UsedRange.Find("Journaltype").column
WspgCol = rsheet.UsedRange.Find("spg").column
WsporgCol = rsheet.UsedRange.Find("spørgsmål").column
WtestCol = rsheet.UsedRange.Find("test").column
Wsv1Col = rsheet.UsedRange.Find("Svar 1").column
Wsv2Col = rsheet.UsedRange.Find("Svar 0").column
Wsv3Col = rsheet.UsedRange.Find("Svar 3").column
WgrpCol = rsheet.UsedRange.Find("Gruppering").column
End Function
Function sortSpgs(key, sheet, sortspg As Boolean)
If Not (sheet.UsedRange.Find(key) Is Nothing) Then
If (sortspg) Then
ResultsWindow.lstGenkendt.AddItem key
End If
sortSpgs = True
Else
If (sortspg) Then
ResultsWindow.lstUgenkendt.AddItem key
End If
sortSpgs = False
End If
End Function
Function Progress()
iProgress = iProgress + 1
Application.StatusBar = iProgress & "% Completed"
End Function
Difficult to debug without the source files.
I see the following potential problems:
GetRowRange: .UsedRange might return more columns than you expect. Check by pressing Ctrl-End in the worksheet and see where you end up
Some thing in your main routine - depsheet.UsedRange.Columns(1).Cells might just result in much more rows than expected
someRange.Value = "VLOOKUP(... will store the formula as text. You need .Formula = instead of .Value (this will not solve your long runtime but certainly avoid another bug)
In sortSpgs you add know or unknow items to a control. Not knowing if there's any event code behind these controls, disable events with Application.EnableEvents=False (ideally in the beginning of your main sub together with the .ScreenUpdating = False)
Also, set Application.Calculation = xlCalculationManual at the beginning and Application.Calculation = xlCalculationAutomatic at the end of your code
You're performing a lot of .Find - esp. in sortSpgs - this is potentially slow in large sheets, as it has to loop over quite some data, depending on the underlying range.
Generally, a few more "best practise remarks":
* Dim your variables with the correct types, same for returns of functions
* Use With obj to make the code cleaner. E.g. in setResulcolVars you could use With rsheet.UsedRange and remove this part in the following 15 or so lines
* In modules of small scope, it is okay to dim some variable with a module wide scope - esp. if you hand them over with every call. This will make your code much easier to read
Hope that helps a bit... mvh /P.
My guess is that Application.Screenupdating is the problem. You set to false inside the:
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
block. So if the isn't the case then screenupdateing isn't disabled. you should move it to the beginning of the function.
you could also try to write the usedrange in an array, work with it , and write it back if needed.
code example
dim MyArr() as Variant
redim MyArray (1 to usedrange.rows.count, 1 to usedrange.columns)
MyArray=usedrange.value
'calculating with Myarray instead of ranges (faster)
usedrange.value=myarray 'writes changes back to the sheet/range
also, maybe you can use .match instead of .find, wich is faster.
with arrays you use application.match( SearchValue, Array_Name, False) 'false if for exact match
the same thing works for range.find() , becoming application.find()...
save first your master workbook under a new name before making such a big change...