I am working on a complex model that needs to lookup values in a series of distinct tables. If I embed all of the information in the model itself, then the file quickly becomes unwieldy. I am hoping to find a solution where I can have a series of CSV files that contain all of the lookup tables, and then have my VBA code just quickly read each CSV file as necessary and return the appropriate value.
My initial thought is to read each CSV file in working memory as needed, lookup the necessary values, then discard the information once the lookups are complete. Is that most efficient way to do it?
Here's an idea which might work for you: load your csv file into a variant array the first time it's required, then subsequent calls will use the cached data. You can lookup values in any column and return the corresponding value from any other column.
EDIT: updated to show how to populate lookup arrays from CSV files
Sub Tester()
Dim arr1, arr2
arr1 = CsvToArray("D:\Analysis\tmp\Data1.csv")
arr2 = CsvToArray("D:\Analysis\tmp\Data2.csv")
Debug.Print TestLookup(arr1, "lookup1", 2, 1)
Debug.Print TestLookup(arr2, "lookup2", 3, 1)
'bunch more lookups...
End Sub
Function TestLookup(arr, val, lookincol As Integer, returnfromcol As Integer)
Dim r
r = Application.Match(val, Application.Index(arr, 0, lookincol), 0)
If Not IsError(r) Then
TestLookup = arr(r, returnfromcol)
Else
TestLookup = "Not found" 'or some other "error" value
End If
End Function
Function CsvToArray(filepath As String) As Variant
Dim wb As Workbook
Application.ScreenUpdating = False
Set wb = Workbooks.Open(filepath)
CsvToArray = wb.Sheets(1).Range("A1").CurrentRegion.Value
wb.Close False
End Function
if you really have to do it in excel, then this is a method:
Function GetData(This As String, ResultCol As Integer)
Dim LastRow As Long
Application.ScreenUpdating = False 'Turn off screen refreshing
Workbooks.Open Filename:="E:\my_files\tables.csv" 'Open the CSV file
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'used for range in vlookup
GetData = Application.WorksheetFunction.VLookup(This, Range(Cells(1, 1), Cells(LastRow, ResultCol)), ResultCol, False)
Workbooks("Tables.csv").Close 'Close the CSV file
Application.ScreenUpdating = True 'Turn on screen refreshing
End Function
Related
EDIT at the bottom of the question
I have a function in my code, that gets a dictionary of samples, fills in data from another workbook and returns filled dictionary. Everything worked fine, but once I changed the opening of the file to be ReadOnly, I experience problems.
Here is the code (which has been simplified to remove redundant parts):
Function get_samples_data(ByVal instructions As Scripting.Dictionary, ByRef patients_data As Scripting.Dictionary) As Scripting.Dictionary
'takes a dictionary of samples and fills their data from the file <0 GL all RL>
Dim wb As Workbook
Dim ws As Worksheet
Dim data_start As Long
Dim data_end As Long
Dim rw As Range
Dim rw_nr As String
'open <GP all> in ReadOnly mode based on path and filename in specific cells
Application.ScreenUpdating = False
Set wb = Workbooks.Open(ThisWorkbook.Sheets(1).Cells(13, 2).Value2 & ThisWorkbook.Sheets(1).Cells(13, 1).Value2, False, True)
Set ws = wb.Worksheets("ALL")
'get row nr. of the first and the last sample to export
data_start = ws.Columns("A:A").Find(what:=instructions("from_sample"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
data_end = ws.Columns("A:A").Find(what:=instructions("to_sample"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
'main loop
For i = data_start To data_end
Set rw = ws.Rows(i)
rw_nr = rw.Cells(1, 1).Value
If rw.Cells(1, 11).Value = instructions("group") Then
If patients_data.Exists(rw_nr) Then
Set patients_data(rw_nr) = fetch_sample_data(rw, patients_data(rw_nr))
End If
End If
Next
'close <GP all> without saving
wb.Close (False)
Set get_samples_data = patients_data
End Function
When I debugged, I noticed, that the data is lost on the call of wb.Close(False). Until that point data is intact, but once the source workbook is closed, the data (which is a range object) is turned blank. Not set to nothing, which happens when the data is not found in the source workbook, but all properties of the range object can be seen in debugger, but all have a value of .
Before I changed the openmode to ReadOnly, everything worked and data stayed there.
What did I miss? Why are data, stored in a different variable, lost?
EDIT:
Fetch sample data indeed returns a range object.
Private Function fetch_sample_data(ByVal rw As Range, ByRef sm As sample) As sample
Dim data As Range
Set data = Range(rw.Cells(1, 19), rw.Cells(1, 63))
Set sm.data = data
Set fetch_sample_data = sm
End Function
I tried changing the order of closing and setting the return value, but the error prevails.
Is it so then, that a Range object is always only a reference to a range in a worksheet? If I want the data to stay, do I need to change all Range objects in question to arrays? Or is there a way to create a Range object independent of a workbook (I do not want to copy the range into any sheet in the main workbook carrying the macro)?
Below is the main sub, as #Pᴇʜ asked for it. I will not add the remaining functions, because the whole code is scattered over 1 form, 2 modules and 14 classes (many carrying long methods).
The two commented open commands are those that caused everything to work properly. The closing commands were at the end of main sub, so in regards to the comment of #Pᴇʜ, if range object is always only a reference to an actual range of cells, they were available for the whole duration of the program.
Sub RL_creator_GP_main()
Dim instructions As New Scripting.Dictionary
Dim samples As Scripting.Dictionary
Dim result_list As Variant
Dim rep As cReport
Dim scribe As New descriptor
Application.ScreenUpdating = False
'get instructions from inputboxes (group, from sample, to sample)
Set instructions = procedures.input_instructions()
If instructions.Exists("terminated") Then
Exit Sub
End If
'get <GP all> and <RL headers> ready
'Call procedures.prepare_file("GP all.xlsx", pth:=ThisWorkbook.Sheets(1).Cells(12, 2).Value)
'Call procedures.prepare_file("RL headers.xlsx", pth:=ThisWorkbook.Sheets(1).Cells(13, 2).Value)
'get patients data from <RL headers>, closes the file afterwards
Set samples = procedures.get_patients_data(instructions)
'get patients data from <GP all>, closes the file afterwards
Set samples = procedures.get_samples_data(instructions, samples)
because samples is submitted ByRef to get_samples_data you don't need to return it:
Sub RL_creator_GP_main()
'your code here …
'get patients data from <RL headers>, closes the file afterwards
Set samples = procedures.get_patients_data(instructions)
'get patients data from <GP all>, closes the file afterwards
procedures.get_samples_data instructions, samples 'this call will change the original samples because it is ByRef!
In fetch_sample_data you add a range to your dictionary. But a Range object is only a reference to the worksheet and does not contain data itself. So instead of that turn the range into an array to add the actual data instead of only a reference:
Private Sub fetch_sample_data(ByVal rw As Range, ByRef sm As sample)
Dim data() As Variant
data = Range(rw.Cells(1, 19), rw.Cells(1, 63)).Value
Set sm.data = data
'again you don't need a function to return the sample as it is ByRef
End Sub
Finally get_samples_data should be a sub not a function. And call fetch_sample_data as a sub like fetch_sample_data rw, patients_data(rw_nr)
Sub get_samples_data(ByVal instructions As Scripting.Dictionary, ByRef patients_data As Scripting.Dictionary)
'takes a dictionary of samples and fills their data from the file <0 GL all RL>
Dim wb As Workbook
Dim ws As Worksheet
Dim data_start As Long
Dim data_end As Long
Dim rw As Range
Dim rw_nr As String
'open <GP all> in ReadOnly mode based on path and filename in specific cells
Application.ScreenUpdating = False
Set wb = Workbooks.Open(ThisWorkbook.Sheets(1).Cells(13, 2).Value2 & ThisWorkbook.Sheets(1).Cells(13, 1).Value2, False, True)
Set ws = wb.Worksheets("ALL")
'get row nr. of the first and the last sample to export
data_start = ws.Columns("A:A").Find(what:=instructions("from_sample"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
data_end = ws.Columns("A:A").Find(what:=instructions("to_sample"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows).Row
'main loop
For i = data_start To data_end
Set rw = ws.Rows(i)
rw_nr = rw.Cells(1, 1).Value
If rw.Cells(1, 11).Value = instructions("group") Then
If patients_data.Exists(rw_nr) Then
fetch_sample_data rw, patients_data(rw_nr)
End If
End If
Next
'close <GP all> without saving
wb.Close (False)
End Sub
Background explanation
Calling functions and subs:
First of all the Call statement is not needed. Parameters in functions are always in parenhesis, the function is used to return a value.
Result = MyFunction(Param1, Param2) ' functions return a result and parameters are in parentesis
MySub Param1, Param2 ' subs don't return a result and don't use parentesis
Call MySub(Param1, Param2) ' But with the Call statement they need parentesis
What does ByRef do:
If you declare a parameter ByRef that means you don't submit data to the sub but only a reference (By Reference) to that data in the memory. So if you have the following sub:
Sub MySub(ByVal Param1, ByRef Param2)
Param1 = 1
Param2 = 2
End Sub
And use it like
Sub Example()
Dim Var1 As Long: Var1 = 10
Dim Var2 As Long: Var2 = 20
MySub Var1, Var2 'note Var2 is submitted ByRef!
Debug.Print Var1, Var2 'returns 10, 2 the value in Var2 got changed by MySub without returning anything
End Sub
So when you submit the variabe by reference that means MySub changes the value in Var2 when performing Param2 = 2 because Param2 and Var2 reference the same space in memory. While if you submit ByVal (by value) you actually make a copy of the data in the memory and Param1 and Var1 reference different places in the memory.
That is why you don't need a function to return something if you submit it ByRef you already changed the data in the memory.
So in your code if you declare Sub get_samples_data(ByVal instructions As Scripting.Dictionary, ByRef patients_data As Scripting.Dictionary) then calling it like procedures.get_samples_data instructions, samples makes patients_data and samples point to the same space in memory. So because the data is only once in the memory and there is only 2 links pointing to them any changes made in one of the links actually edits the exact same data in memory. Therefore you don't need to return data.
I'm running a VBA for each loop through an Excel table (Listobject) which checks if a file exists based on a given path. My table has expanded though and has 68K Listrows. After launching the code, it quickly gives an error Run-time-error '7': Out of memory
It runs OK with 63K lines (done within 5 minutes) and based on googling there appears to be something called "64K segment boundary". Is this what's affecting my code to run since it really feels like it buffers the row count at first and then bounces back w/o starting to actually run anything. Is there an easy workaround for this without the need to split up my dataset into multiple batches? Frankly, I was quite surprised that 64K limits would still be a thing in Excel in 2021.
Running it on 64bit Excel 2019, but no luck with Office365 either.
Sub CheckFiles()
Dim Headers As ListObject
Dim lstrw As ListRow
Dim strFileName As String
Dim strFileExists As String
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Import")
Set Headers = ws.ListObjects("Import")
For Each lstrw In Headers.ListRows
strFileName = lstrw.Range(7)
strFileExists = Dir(strFileName)
If strFileExists = "" Then
lstrw.Range(4) = "not found"
Else
lstrw.Range(4) = "exists"
End If
Next lstrw
Set ws = Nothing
Set Headers = Nothing
Application.ScreenUpdating = True
End Sub
Avoid Accessing the Worksheet
Since you cannot avoid looping, you better do it in the computer's memory, i.e. rather through the elements of an array than through the cells of a range.
The code is still slow, about 10s for 200k rows on my machine, but that's because of Dir.
Note how easy (one line only, when the range contains more than one cell) and how fast (a split second) it is to write (copy) a range to an array (Data = rg.Value) and write (copy) the array back to a range (rg.Value = Data).
Adjust the values in the constants section.
Option Explicit
Sub CheckFiles()
Const wsName As String = "Import" ' Worksheet Name
Const tblName As String = "Import" ' Table Name
Const cCol As Long = 7 ' Criteria Column
Const dCol As Long = 4 ' Destination Column
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim Headers As ListObject: Set Headers = ws.ListObjects(tblName)
Dim Data As Variant ' Data Array
With Headers.ListColumns(cCol).DataBodyRange
If .Rows.Count = 1 Then
ReDim Data(1 To 1, 1 To 1): Data = .Value
Else
Data = .Value
End If
End With
Dim r As Long ' Array Row Counter (DataBodyRange Row Counter)
Dim FileName As String ' File Name Retrieved by Dir
For r = 1 To UBound(Data, 1)
FileName = Dir(CStr(Data(r, 1)))
If Len(FileName) = 0 Then
Data(r, 1) = "not found"
Else
Data(r, 1) = "exists"
End If
Next r
Headers.ListColumns(dCol).DataBodyRange.Value = Data
End Sub
Thank you all! A few takeaways. While obviously trying to write as efficient code as possible, any reasonable performance here is acceptable. With that said, for each loop took approx 5 minutes to run with 63K lines, meawhile it was done in about 15 seconds by the code I accepted as an answer by #VBasic2008 - without capacity problems either.
The only problem I had with this particular code was it being somewhat new approach for me, so possibly building on it in the future needs some dedication in looking deeper into it - but it sure looks efficient. I also put together a regular for ... to loop which also didn't run into problems with 68K lines and would steer between rows and columns with offset function.
Clearly faster than for each as #Pᴇʜ suggested but took approx 2x as long as the array method (30 seconds or so).
Sub CheckFiles_2()
Dim strFileName, strFileExists As String
Dim ws As Worksheet
Dim Headers As ListObject
Dim result As String
Dim counter, RowCount As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Import")
Set Headers = ws.ListObjects("Import")
RowCount = Headers.ListRows.Count
For counter = 1 To RowCount
strFileName = Range("anchorCell").Offset(counter, 3)
strFileExists = Dir(strFileName)
If strFileExists = "" Then
result = "not found"
Else
result = "exists"
End If
Range("anchorCell").Offset(counter, 0) = result
Next counter
Set ws = Nothing
Set Headers = Nothing
Application.ScreenUpdating = True
End Sub
I have a list of files with the same structure and I want to extract some information from columns A, B, and C and print it to another workbook.
I found a way to do it for a single file, but now I don't understand how can I do it using the list of given files. I tried using collections, but it doesn't work.
Here's what I came up with:
Sub Pulsante1_Click()
Dim FileGeStar As Variant
Dim myCol As Collection
Set myCol = New Collection
myCol.Add "C:\Users\xxx\Desktop\articoli_def.xlsx"
myCol.Add "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx"
For Each FileGeStar In myCol
Workbooks.Open Filename:=FileGeStar
FileGeStar = Application.ActiveWorkbook.Name
Dim Code As String
Dim Description As String
Dim FilePath As String
Dim i As Long
i = 2
While Range("A" & i) <> ""
FilePath = Application.ActiveWorkbook.Path
Code = Trim(Range("A" & i).Value)
Description = Trim(Range("B" & i).Value)
Workbooks("Report.xlsm").Worksheets(1).Range("A" & i).Value = FilePath
Workbooks("Report.xlsm").Worksheets(1).Range("B" & i).Value = Code
Workbooks("Report.xlsm").Worksheets(1).Range("C" & i).Value = Description
i = i + 1
Wend
Next FileGeStar
End Sub
What can I do?
This might look like an overkill, but I hope the code and comment's are self explanatory:
Option Explicit
Sub Pulsante1_Click()
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = ThisWorkbook 'I think report.xlsm is the workbook running the code
'if report.xlsm is not the workbook running the code then change thisworkbook for workbooks("Report.xlsm")
'add as many paths as you need to, another way would be to write them in a sheet and loop through to fill the array
Dim MyPaths As Variant
MyPaths = Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'Declare a workbook variable for the source workbooks
Dim SourceWorkbook As Workbook
'Declare a long variable to loop through your path's array
Dim i As Long
'loop through the start to the end of your array (will increase as the array does)
For i = LBound(MyPaths) To UBound(MyPaths)
Set SourceWorkbook = OpenWorkbook(MyPaths(i)) 'this will set the workbook variable and open it
CopyData SourceWorkbook, DestinationWorkbook 'this will copy the data to your destination workbook
SourceWorkbook.Close , False
Set SourceWorkbook = Nothing
Next i
End Sub
Private Function OpenWorkbook(FullPath As String) As Workbook
Set OpenWorkbook = Workbooks.Open(FullPath, False, True)
End Function
Private Sub CopyData(wbO As Workbook, wbD As Workbook)
'this procedure calculates the last row of your source workbook and loops through all it's data
'later calls the AddDataToMasterWorkbook procedure to paste the data
With wbO.Sheets(1) 'Im assuming your source workbook has the data on sheet1
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Dim FilePath As String
FilePath = wbO.Path
Dim Code As String
Dim Description As String
Dim C As Range
For Each C In .Range("A2:A" & LastRow) 'this will loop from A2 to the last row with data
Code = Trim(C)
Description = Trim(C.Offset(, 1))
AddDataToMasterWorkbook wbD, FilePath, Code, Description
Next C
End With
End Sub
Private Sub AddDataToMasterWorkbook(wb As Workbook, FilePath As String, Code As String, Description As String)
'This procedure calculates the last row without data and adds the items you need every time
With wb.Sheets(1)
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow) = FilePath
.Range("B" & LastRow) = Code
.Range("C" & LastRow) = Description
End With
End Sub
To loop though files, you can indeed use a collection, or an array, you can also loop through all files in directory with certain extension, or partial file name. Check out DIR function.
Best not to use ActiveWorkbook, better approach would be to set a workbook object like so: Set wb = Workbooks.Open(fullPathToYourWorkbook).
For what you're doing, there's no need to go row by row, much more efficient way would be to copy entire range, not only it's a lot quicker but also it's only 1 line of code; assuming your destination is ThisWorkbook.Sheets(1) and wb object is set: wb.Range("A:C").Copy Destination:=Thisworkbook.Sheets(1).Range("A:C"). If you need to edit copied data (trim or whatever) consider Range Replace method.
However, if you want to go row by row for whatever reason, as BigBen mentioned in the comment - get rid of While loop.
It's a good idea to set Application.ScreenUpdating to False when opening/closing workbooks, then back to True once it's all done. It will prevent user from accidentaly clicking something etc and will make it look like it's not opening any workbook.
Here's my approach (untested) assuming the workbook you want to copy data to is Workbooks("Report.xlsm").Worksheets(1):
Sub Pulsante1_Click()
'set workbook object for the destination workbook
set wb_dest = Workbooks("Report.xlsm").Worksheets(1)
'disable screen updating
Application.ScreenUpdating = False
For Each target_wb In Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'set wb object and open workbook
Set wb = Workbooks.Open(target_wb)
'find last row in this workbooks in columns A:B (whichever is greater)
LastRow = wb.Range("A:B").Find(What:="*", After:=wb.Range("A1"), SearchDirection:=xlPrevious).row
'copy required data
wb.Range("A1:B" & LastRow).Copy Destination:=wb_dest.Range("B1:C" & LastRow)
'fill column A with path to the file
wb_dest.Range("A1:A" & LastRow).Value = wb.Path
'close workbook
wb.Close False
Next
'enable screen updating
Application.ScreenUpdating = True
End Sub
Obviously an array is not the best approach if you have loads of different files, collection would be a lot clearer to read and edit in the future, unless you want to create a dynamic array, but there's no need for that in my opinion. I didn't declare variables or write any error handling, it's a simple code just to point you in the right direction.
If you want to disable workbook events or/and alerts, you can set Application.DisplayAlerts and Application.EnableEvents to False temporarily.
I don't have much experience with VBA so it's been difficult to troubleshoot this. When running the code, it outputs Array(i<=i) instead of Array(i)
I've tested the for condition and found Array(0) properly returns the result. However Array(1) will print Array(1) with Array(0) and so on.
The goal of this code is to group worksheets based on their name and print them to pdfs based on grouping, i.e. all sheets starting with I1 to a single pdf.
Sub Test()
FolderPath = "C:\Example"
Dim aWS()
Dim n As Integer
Dim ws As Worksheet
Dim DocTypes()
DocTypes = Array("I1","I2","I3")
For i = LBound(DocTypes) To UBound(DocTypes)
For Each ws In Worksheets
If Left(ws.Name, 2) = DocTypes(i) Then
n = n + 1
ReDim Preserve aWS(1 To n) 'Add 1 to to array length
aWS(n) = ws.Name 'Add worksheet name meeting If condition
End If
Next ws
Sheets(aWS).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderPath &
DocTypes(i), _
openafterpublish:=True, ignoreprintareas:=False
Next i
End Sub
What I expect is:
i = 0 to 2
First Array(i) = "I1" so output all sheets beginning with "I1" as a pdf
Then move to i = 1
Here Array(i) = "I2" so output all sheets beginning with "I2" as a pdf
However when I step forward it doesn't seem to be following this logic and I don't understand why. I'm thinking it has to do with the selection, it would follow that if i=0 was selected, then i=1 was added to the selection this problem would make sense. I've tried re-selecting a single sheet right before Next i to force past this but it didn't work. This leads me to think I've made a logical mistake in my for loops.
You might not be aware but you can use a variant as a control variable in a for each to iterate an array of variants. Your use of redim to extend an array by 1 item suggests that you should be using a scripting dictionary as an intermediate step to your array. The .Items method of a scripting dictionary returns an array of items so it is easy to get your array that you use subsequently. Here is your code revised to use a scripting.dictionary and a variant control variable. In your specific case we are basically using the scripting.dictionary as a list by making the key and the item the same thing.
Option Explicit
Sub Test()
Const FolderPath As String = "C:\Example"
Dim aWS As Scripting.Dictionary
Dim ws As excel.Worksheet
Dim DocTypes() As Variant
Dim DocType As Variant
DocTypes = Array("I1", "I2", "I3")
For Each DocType In DocTypes
Set aWS = New Scripting.Dictionary
For Each ws In Worksheets
If DocType = left(ws.Name, 2) Then
aWS.Add Key:=ws.Name, Item:=ws.Name
End If
Next ws
Sheets(aWS.Items).Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FolderPath & DocType, _
openafterpublish:=True, _
ignoreprintareas:=False
Next
End Sub
Use Selection.ExportAsFixedFormat etc instead of ActiveSheet. The ActiveSheet is always only one sheet while your selection comprises many.
Upon further study I find that you may have to include making a selection for each of the worksheets, like Ws.UsedRange.Select. Take a look at this thread.
I have a column in a spreadsheet.
The format of the data in each cell is aa-0001-xx.
I need to examine the whole column to find the highest value of the sequence number. this would be the substring from column4 thru column7.
I can find the sequence number using Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4)
But I need to find the max sequence in the whole column.
I am doing this in VBA.
Any help would be appreciated.
Here is my code so far:
Private Sub CommandButton1_Click()
Dim sQuoteNumber As String
Dim sFileName As String
Dim sPathName As String
Dim checkit As String
'Log the Quote
'First, open the log file and determine the next sequential log number.
sPathName = "C:\Users\Rich\Documents\Bryan\BigProject\"
sFileName = "QuoteLog2016.xlsx"
ControlFile = ActiveWorkbook.Name
Workbooks.Open Filename:=sPathName & sFileName
'Create the new Quote Number
checkit = Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) ' This is a temp test line
If Mid(ActiveWorkbook.Sheets("Sheet1").Range("B2:B2"), 4, 4) = "" Then
sQuoteNumber = "16-0001"
Else
'find the biggest number
'Here I was looking to like pass the mid function to a Max function of some sort.
sQuoteNumber = "16-0002"
End If
MsgBox ("The new Quote Number is: " + sQuoteNumber)
'Save the log entry
Workbooks(sFileName).Close
All of the comments made to your answer would work well for you. It's also true that there's no evidence in your code at having attempted something, however rudimentary, and this is why answers to a rather trivial task are not forthcoming for you. Perhaps, in future, have a go at some kind of solution ( even if it feels more guesswork than anything) and people on this site will be much more supportive of you.
To set you on your way, you could make use of the Split() function which converts a String into a String array, separated by a nominated value - in the case of your quotations, you could use "-" as your separator. This might be easier than your Mid function and will deal with the case of different sized quotations.
The code below will get you started but you'd want some error handling in there to test, for example, that each cell splits appropriately or that any cells aren't blank. I'll leave all of that to you.
Option Explicit
Private mLastQuote As Long
Public Sub Test()
Initialise 'call this routine just once at the start of your project
MsgBox GetNextQuote(16) 'use the GetNextQuote() function to get next number
MsgBox GetNextQuote(16)
MsgBox GetNextQuote(16)
End Sub
Private Function GetNextQuote(prefix As Integer) As String
mLastQuote = mLastQuote + 1
GetNextQuote = CStr(prefix) & "-" & _
Format(mLastQuote, "000#")
End Function
Private Sub Initialise()
Const PATH_NAME As String = "C:\Users\Rich\Documents\Bryan\BigProject\"
Const FILE_NAME As String = "QuoteLog2016.xlsx"
Const QUOTE_COL As String = "B"
Dim wb As Workbook
Dim ws As Worksheet
Dim v As Variant
Dim r As Long
Dim parts() As String
Dim num As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Open(PATH_NAME & FILE_NAME, True, True)
Set ws = wb.Worksheets("Sheet1")
'Read quote values into variant array
With ws
v = .Range(.Cells(2, QUOTE_COL), _
.Cells(.Rows.Count, QUOTE_COL).End(xlUp)) _
.Value2
End With
'Find max quote
For r = 1 To UBound(v, 1)
parts = Split(v(r, 1), "-") 'splits quote into 3 parts
num = CLng(parts(1)) 'index (1) is the middle part
If num > mLastQuote Then mLastQuote = num
Next
wb.Close False
Application.ScreenUpdating = True
End Sub