excel vba regex pattern exact string match

Hi I’m trying to fix my code to do the following (with some context)

There are 2 columns in excel: column P and column S. Both columns are thousands and thousands of rows long.

Column P are all multi-lined text strings (descriptions of products)
Column S are all multi-lined text strings (comments of products)

I need to write a vba function that will look into the cell in column P and return the exact string match if there is a match pertaining to the values in column S.

Example:

Using regular expressions I have been able to do this comparing one row at a time (P3 to S3) using the code below:

Public Function RxMatch( _
ByVal SourceString As String, _
ByVal Pattern As String, _
Seperator As String, _
Optional ByVal IgnoreCase As Boolean = True, _
Optional ByVal MultiLine As Boolean = True) As Variant

Dim arrWords() As String
arrWords = Split(SourceString, separator)

Dim oMatches As MatchCollection
For Each word In arrWords
With New RegExp
.MultiLine = MultiLine
.IgnoreCase = IgnoreCase
.Global = False
.Pattern = Pattern
Set oMatches = .Execute(SourceString)
If oMatches.Count > 0 Then
RxMatch = oMatches(0).Value
Else
RxMatch = "No match"
End If
End With
Next word

End Function


however instead of comparing P3 to S3 for a match I need to compare P3 to all of column S to see if any of the descriptions have a match. Is there a way to update this code that I provided so that it matches off of the entire column S instead of cell to cell?

With as many entries as you have, you’re probably going to have trouble finding an efficient way to do this. A nested foreach loop is the most obvious approach, but it will be slow.
– emsimpson92
Jul 2 at 21:15

foreach

Using arrays will be much quicker.
– SJR
Jul 2 at 21:25

arrays and Instr? Sorry, I can’t enlarge image at present to view data properly.
– QHarr
Jul 2 at 21:46

Does VLOOKUP help you? In my experience, it is faster than VBA.
– Bogdan
Jul 2 at 22:44

Are you just checking to see if any of the substrings in column S are contained in the longer strings in column P? Your image is very small and hard to see.
– jeffreyweir
Jul 2 at 22:58

1 Answer
1

If you are careful about any hidden characters, line breaks etc then you should be able to use arrays and Instr function.

Option Explicit
Public Sub FindMatches()
Dim arr(), i As Long, j As Long
With ActiveSheet
arr = .Range("P1:T" & .Cells(.Rows.Count, "P").End(xlUp).Row).Value
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 1) To UBound(arr, 1)
If InStr(arr(i, 1), arr(j, 4)) > 0 Then arr(i, 5) = arr(i, 5) & "," & arr(j, 4)
Next j
Next i
For i = LBound(arr, 1) To UBound(arr, 1)
arr(i, 5) = Application.WorksheetFunction.Substitute(arr(i, 5), ",", vbNullString, 1)
Next i
.Range("P1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub


Dataset with output in column T:

Any feedback at all?
– QHarr
Jul 4 at 5:40

By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

VBA to Find and Replace into different column, same row, SKIP IF Cell has a value

enter image description hereI’ve developed an elaborate database to log nameplate values of Heater Equipment as it is replaced. For failure trending purposes, I don’t want to overwrite the information about the previous installation when a heater is replaced, but rather log the nameplate information into the next series of columns over. I’m looking for code to say; If any column in the “Installation 1″ section is filled in, skip to “Installation 2″ section and paste…etc. This is button driven in a previous statement. enter code here

enter code here

Sub DataEntry_HeaterInstallations()

Dim cell As Range, rngFind As Range, counter As Long

'Use heater name in cell L3 as the search criteria

With Sheet1
Set rngFind = .Range("L3")
End With

'Search in worksheet "PIPES DATABASE" for heater name

For Each cell In rngFind

Set Found = Sheets("PIPES DATABASE").Range("U1:U1773").Find(What:=cell.Value, _
LookIn:=xlValues, _
MatchCase:=False)

'When a match is found, replace
'Overwrites formulas

If Not Found Is Nothing Then

' INSTALLATION 1

'If Found.Offset(Cells(0, 24), Cells(0, 35)) = blank Then

Found.Offset(0, 24).Value = cell.Offset(2, -7).Value 'Date
Found.Offset(0, 26).Value = cell.Offset(27, -7).Value 'Heater Length - Hot
Found.Offset(0, 27).Value = cell.Offset(28, -7).Value 'Heater Length - Cold
Found.Offset(0, 28).Value = cell.Offset(26, 4).Value 'Heater Ohms (Per/Ft)
Found.Offset(0, 29).Value = cell.Offset(27, 4).Value 'Heater Ohms Total
Found.Offset(0, 30).Value = cell.Offset(28, 15).Value 'Heater Voltage (VAC)
Found.Offset(0, 31).Value = cell.Offset(26, 15).Value 'Heater Power (Wt/Ft)
Found.Offset(0, 32).Value = cell.Offset(27, 15).Value 'Heater Power TOTAL (Watts)
Found.Offset(0, 33).Value = cell.Offset(26, -7).Value 'Manufacturer
Found.Offset(0, 34).Value = cell.Offset(3, -7).Value 'Work Order #
Found.Offset(0, 35).Value = cell.Offset(5, -7).Value 'Technician Name

' INSTALLATION 2

Found.Offset(0, 38).Value = cell.Offset(2, -7).Value 'Date
Found.Offset(0, 40).Value = cell.Offset(27, -7).Value 'Heater Length - Hot
Found.Offset(0, 41).Value = cell.Offset(28, -7).Value 'Heater Length - Cold
Found.Offset(0, 42).Value = cell.Offset(26, 4).Value 'Heater Ohms (Per/Ft)
Found.Offset(0, 43).Value = cell.Offset(27, 4).Value 'Heater Ohms Total
Found.Offset(0, 44).Value = cell.Offset(28, 15).Value 'Heater Voltage (VAC)
Found.Offset(0, 45).Value = cell.Offset(26, 15).Value 'Heater Power (Wt/Ft)
Found.Offset(0, 46).Value = cell.Offset(27, 15).Value 'Heater Power TOTAL (Watts)
Found.Offset(0, 47).Value = cell.Offset(26, -7).Value 'Manufacturer
Found.Offset(0, 48).Value = cell.Offset(3, -7).Value 'Work Order #
Found.Offset(0, 49).Value = cell.Offset(5, -7).Value 'Technician Name

' INSTALLATION 3

Found.Offset(0, 52).Value = cell.Offset(2, -7).Value 'Date
Found.Offset(0, 54).Value = cell.Offset(27, -7).Value 'Heater Length - Hot
Found.Offset(0, 55).Value = cell.Offset(28, -7).Value 'Heater Length - Cold
Found.Offset(0, 56).Value = cell.Offset(26, 4).Value 'Heater Ohms (Per/Ft)
Found.Offset(0, 57).Value = cell.Offset(27, 4).Value 'Heater Ohms Total
Found.Offset(0, 58).Value = cell.Offset(28, 15).Value 'Heater Voltage (VAC)
Found.Offset(0, 59).Value = cell.Offset(26, 15).Value 'Heater Power (Wt/Ft)
Found.Offset(0, 60).Value = cell.Offset(27, 15).Value 'Heater Power TOTAL (Watts)
Found.Offset(0, 61).Value = cell.Offset(26, -7).Value 'Manufacturer
Found.Offset(0, 62).Value = cell.Offset(3, -7).Value 'Work Order #
Found.Offset(0, 63).Value = cell.Offset(5, -7).Value 'Technician Name
End If

Next cell

MsgBox "Database Updated"

End Sub


When you get your code working you should post it to Code Review. With screenshots of data on both Sheet1 and Sheets("PIPES DATABASE"). Mocking up a download file would not hurt. Your project would be much easier to create, modify, and extend if you had each record on its own row like a table in a normal database. The Sheets("PIPES DATABASE") view can be created from that table using a Pivot Table.
– TinMan
Jul 2 at 20:00

Sheet1

Sheets("PIPES DATABASE")

Sheets("PIPES DATABASE")

1 Answer
1

Notice in my refactored code that I modified Range("U1:U1773") to extend from U1 to the last used row. I also added a loop to find the next installation.

Range("U1:U1773")

U1

Sub DataEntry_HeaterInstallations()

Dim cell As Range, rngFind As Range, counter As Long
'Use heater name in cell L3 as the search criteria

With Sheet1
Set rngFind = .Range("L3")
End With

'Search in worksheet "PIPES DATABASE" for heater name

For Each cell In rngFind
With Sheets("PIPES DATABASE")
Set Found = .Range("U1", .Range("U" & .Rows.Count).End(xlUp)).Find(What:=cell.Value, LookIn:=xlValues, MatchCase:=False)
End With

'When a match is found, replace
'Overwrites formulas

If Not Found Is Nothing Then

' INSTALLATION 1

Do Until Found.Offset(0, 24).Value = vbNullString
Set Found = Found.Offset(0, 14)
Loop

Found.Offset(0, 24).Value = cell.Offset(2, -7).Value 'Date
Found.Offset(0, 26).Value = cell.Offset(27, -7).Value 'Heater Length - Hot
Found.Offset(0, 27).Value = cell.Offset(28, -7).Value 'Heater Length - Cold
Found.Offset(0, 28).Value = cell.Offset(26, 4).Value 'Heater Ohms (Per/Ft)
Found.Offset(0, 29).Value = cell.Offset(27, 4).Value 'Heater Ohms Total
Found.Offset(0, 30).Value = cell.Offset(28, 15).Value 'Heater Voltage (VAC)
Found.Offset(0, 31).Value = cell.Offset(26, 15).Value 'Heater Power (Wt/Ft)
Found.Offset(0, 32).Value = cell.Offset(27, 15).Value 'Heater Power TOTAL (Watts)
Found.Offset(0, 33).Value = cell.Offset(26, -7).Value 'Manufacturer
Found.Offset(0, 34).Value = cell.Offset(3, -7).Value 'Work Order #
Found.Offset(0, 35).Value = cell.Offset(5, -7).Value 'Technician Name
End If

Next cell

MsgBox "Database Updated"

End Sub


By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

Difference Between Strings and Names on VBA. Strings referencing ranges on different sheets

Hello again Stack OverFlow Community! I am a very big noob to VBA still but trying to figure out whats going on here. I pieced together some of my code for you guys below. Im working in the sheet Data but everytime I run the code below I get an error on line “Set Banks = DataS.Range(“X9:X11″)" saying that I cant use the DataS.Range part of the code. If I use it without DataS.Range Im good.

What Im trying to figure out is why I can assign TypofDeal a range no problem but I cant assign Banks the same range even though there both strings.

The code eventually will need to be able to assign Banks to DS.Range(“X9:X11″) which is a similar range but on a different sheet.

The internet told me to use a Names.Add function but I dont understand why I need to!! What is the difference between a “Name" and a “String"!!

Thanks guys!!

Dim DS As Worksheet
Set DS = ThisWorkbook.Worksheets("Design")
Dim DataS As Worksheet
Set DataS = ThisWorkbook.Worksheets("Data")

Dim TypeofDeal As String, Banks As String
Dim Bank As Range, Label As Range, Line As Range
Set Line = DataS.Range("V22:W22")
TypeofDeal = DataS.Range("W21")
Banks = DataS.Range("X9:X11")

If TypeofDeal = "Purchase" Then
Line.Delete

Else
Line.Select
Selection.Insert Shift:=xlDown
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
Set Label = DataS.Range("V22") 'Variable
Set Bank = DataS.Range("W22") 'Variable

Label.Select
Selection.Value = "Financing Company"
Selection.Borders.Weight = xlThin

Bank.Select
Bank.Value = " "
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="=" & Banks
.IgnoreBlank = True
.InCellDropdown = True
End With
Selection.Borders.Weight = xlThick
Selection.Borders.ColorIndex = 23

End If


In your code sample you do not use Set just Banks = DataS.Range("X9:X11").
– TinMan
Jul 3 at 1:30

Set

Banks = DataS.Range("X9:X11")

There is no need to work with named ranges but they are quite useful. You should read The VBA Guide To Named Ranges.
– TinMan
Jul 3 at 1:35

You should google wiseowltutorials excel vba introduction. This video series is excellent.
– TinMan
Jul 3 at 1:37

1 Answer
1

The reason you are getting an error on this:

Banks = DataS.Range("X9:X11")


but, not on this:

TypeofDeal = DataS.Range("W21")


Is because:

TypeofDeal = DataS.Range("W21")


is only using the value from one cell, which is valid. Whereas this:

Banks = DataS.Range("X9:X11")


is an attempt to assign the values from 3 cells to one string, which is not valid.

If you need to add the values from all three cells to the same string, you could do something like this:

Banks = DataS.Range("X9").Value & DataS.Range("X10").Value & DataS.Range("X11").Value


If that alone doesn’t solve your problem, I’ll need to see the data that would be in the cells in question and then I can test your whole solution and perhaps provide a more thorough answer.

Also, I don’t see any substantial benefit to using a named range in this scenario, at least, not based on the code you’ve provided.

Gotcha. Whats really crazy is the code works with Banks = (“X9:X11″)!!! Isn’t that strange?! And the Name. function was the only one that validation list code will accept if the data is on another sheet. Otherwise the Banks = (“X9:X11″) code works fine
– ITMikeT
Jul 4 at 0:50

Weird. When I try Banks = ("X9:X11") , Banks only returns “X9:X11″, not the actual data in the cells.
– SeanW333
Jul 4 at 3:22

Banks = ("X9:X11")

By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

Remove duplicates within a time range in vba (e.g. duplicates within a week)

I am working on a study where a study participant counts as a duplicate if they participate again within two weeks but they aren’t a duplicate if they participate again after the 2 week cool down period. I need a way of checking/removing duplicate participants within 2 weeks but keeping them if they are a duplicate outside 2 weeks.

The data looks something like this:

Test Participant ID Date
1 550 01/01/2018
2 550 02/01/2018
3 677 05/01/2018
4 550 15/02/2018


Normally I would use Range.RemoveDuplicates to just remove duplicates. This would remove tests 2 and 4.

Sub removeduplicate()
Range("A1:C5").CurrentRegion.RemoveDuplicates Columns:=Array(2), Header:=xlYes
End Sub


Is there any way to modify or add to this so that I remove the duplicate in Row 2 but not the duplicate in Row 4 (since it is after more than 2 weeks)? I have thousands of rows.

Thank you so much

you could add a column with a formula that determines whether this record is should be considered a duplicate, perhaps returning TRUE/FALSE, and then use RemoveDuplicates based on that column. Without example data, expected output, or sample code, it’s tough to give you anything more specific than that. (See “How to Ask" as well as the help center, plus great tips here.)
– ashleedawg
Jul 3 at 3:30

TRUE

FALSE

RemoveDuplicates

Thank you ashleedawg, I have added some example data and the code I have been using to remove general duplicates.
– Kurt
Jul 3 at 10:26

1 Answer
1

Try this to remove duplicates

Sub Duplicates()

Dim i As Long
i = ActiveSheet.UsedRange.Rows.Count
x = Cells(2, 2).Value
For j = 3 To i
If Cells(j, 2).Value = "" Then
Cells(j, 2).Value = x
Else
x = Cells(j, 2).Value
End If
Next j
End Sub


By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

Loop through all TableFields in Microsoft Project add to combobox

I’m stuck trying to create a UserForm in VBA with a combobox that lists all possible TableFields(?).

Updated code:
Using the code provided by @dbmitch and some freestyle.
This lists a two-column combobox with both the Original and the Custom field name (if it exists). It only lists the fields used in the Activeproject. Not all possible fields. But if the field isn’t used in the Activeproject anyway… maybe this is for the best!

Public strResult2 As String ' Used for custom field names

Private Sub UserForm_Initialize()
Dim objProject As MSProject.Project
Dim tskTable As MSProject.Table
Dim tskTables As MSProject.Tables
Dim tskTableField As MSProject.TableField
Dim strFieldName As String

'ComboBoxColA.ListWidth = "180" 'Uncomment for wider dropdown list, without wider box

Set objProject = Application.ActiveProject
Set tskTables = objProject.TaskTables

With ComboBox1 'Adds one blank line at the top
.ColumnCount = 2
.AddItem ""
.Column(1, 0) = "BLANK"
End With

' Loop through all tables
For Each tskTable In tskTables
' Loop through each field in each table
For Each tskTableField In tskTable.TableFields
strFieldName = GetFieldName(tskTableField)
If Len(strFieldName) = 0 Then GoTo SKIPHERE
With ComboBox1
.Value = strFieldName
' Check if allready exists
If .ListIndex = -1 Then
' Then sort alphabetically
For x = 0 To .ListCount - 1
.ListIndex = x
If strFieldName < .Value Then
.AddItem strFieldName, x
.Column(1, x) = strResult2
GoTo SKIPHERE
End If
Next x
.AddItem strFieldName
End If
End With
SKIPHERE:
Next
Next

Set objProject = Nothing
Set tskTable = Nothing
Set tskTables = Nothing
Set tskTableField = Nothing
End Sub


Function

Private Function GetFieldName(ByVal objField As MSProject.TableField) As String
' find the field name and column header for a field (column) in a data table
'strResult is placed in column 0 in ComboBox
'strResult2 is placed in column 1 in ComboBox

Dim lngFieldID As Long
Dim strResult As String

lngFieldID = objField.Field

With objField.Application
strResult = Trim(.FieldConstantToFieldName(lngFieldID))
On Error GoTo ErrorIfMinus1 ' CustomField does not handle lngFieldID= -1
If Len(Trim(CustomFieldGetName(lngFieldID))) > 0 Then strResult2 = " (" & Trim(CustomFieldGetName(lngFieldID)) & ")" Else strResult2 = ""
End With

GetFieldName = strResult
Exit Function

ErrorIfMinus1:
strResult2 = ""
Resume Next
End Function


@dbmitch helped me on my way getting this code to work. Thanks!

Are you using the code in MS Project? Your example of MSProject.FieldNameList is confusing
– dbmitch
Jul 2 at 23:31

MSProject.FieldNameList

If you really mean “Table Fields" then the solution above is sufficient. However, if you want all possible Task fields, this will not work as it will not include fields that are not part of any table, which will be many. For example, the numbered Text, Number, Date, etc. fields are not part of any standard table (e.g. Text10). You could add them to a table, but there are hundreds of fields. Note there is no built-in enumeration for all task fields.
– Rachel Hettinger
Jul 3 at 0:55

A better solution is to store the list of field constants for the fields you want to include and iterate over that. See this SO answer for suggestions on how to do that: stackoverflow.com/questions/32209245/loop-through-each-field-for-ms-project….
– Rachel Hettinger
Jul 3 at 0:56

Sorry if my example is more confusing than helping. The VBA code is meant for MS project indeed. I mean all task fields, yes. @RachelHettinger I must believe you when you say MS Project is not able to enumerate all fields, but I have to wonder how Project is able to list all available fields when you try to insert a column?
– Doons
Jul 3 at 8:17

I would be fine if I just were able to list all the properties listed on this page: msdn.microsoft.com/en-us/vba/project-vba/articles/…
– Doons
Jul 3 at 8:17

1 Answer
1

That link is useful in that it shows the properties and methods available to you via the MS Project object model. You should be able to modify it to VBA format by changing it slightly.

What would have been more useful was to show your code you mentioned in…

I have found code that let me list all fields in the current table

In any case, see if this code does what you want as described in your question

Sub LoadFieldNames()
Dim objProject As MSProject.Project

Dim tskTable AS MSProject.Table
Dim tskTables AS MSProject.Tables
Dim tskTableField AS MSProject.TableField

Dim strFieldName AS String

Set objProject = Application.ActiveProject
Set tskTables = objProject.TaskTables

' Loop thru all tables
For Each tskTable In tskTables

' Loop through each field in each table
For Each tskTableField in tskTable.TableFields
strFieldName = GetFieldName(tskTableField)
ComboBox1.AddItem strFieldName
Next
Next

Set objProject = Nothing
Set tskTable = Nothing
Set tskTables = Nothing
Set tskTableField = Nothing

End Sub


Try adding the function from this post to create the function GetFieldName … and it should compile

GetFieldName

Private Function GetFieldName(ByVal objField As MSProject.TableField) As String
' find the field name (actually colmn heading) for a field (column) in a data table

Dim lngFieldID As Long
Dim strResult As String

lngFieldID = objField.Field

With objField.Application
strResult = Trim(objField.Title) ' first choice is to use the title specified for the column in the table

If Len(strResult) = 0 Then
' try to get the custom field name- this will come back blank if it's not a custom field
strResult = Trim((CustomFieldGetName(lngFieldID)))
End If

If Len(strResult) = 0 Then
strResult = Trim(.FieldConstantToFieldName(lngFieldID)) ' use the field name
End If
End With

GetFieldName = strResult
End Function


Note: this code is an incomplete translation of the link in the question and it contains at least one error (objProject.tskTables should be objProject.TaskTables).
– Rachel Hettinger
Jul 3 at 1:10

objProject.tskTables

objProject.TaskTables

Thanks for spotting that error. Code is only adapted for OP questions
– dbmitch
Jul 3 at 3:17

The code still won’t compile since GetFieldName is not defined—that’s the part of the code translation that is incomplete and it is absolutely related to the OP’s question.
– Rachel Hettinger
Jul 3 at 4:03

Thanks for looking into this! I just tried the updated code and function, but I get a runtime error 1004 on the line strResult = Trim((CustomFieldGetName(lngFieldID)))
– Doons
Jul 3 at 8:30

strResult = Trim((CustomFieldGetName(lngFieldID)))

It does compile, error 1004. lngFieldID = -1
– Doons
Jul 3 at 15:22

By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

DTD Error loading XML using MSXML2.DOMDocument60

I have a series of functions already developed for working on xml files using MSXML2.DOMDocument60. However, when I try to load a html page using the code below I get an error saying

MSXML2.DOMDocument60

“DTD is not allowed"

. Does anyone know what I’m doing wrong?

Dim xml As MSXML2.DOMDocument60
Set xml = New MSXML2.DOMDocument60

If xml.Load(pathToHtml) Then
Debug.Print "Success"
Else
Debug.Print "Could not load the document: " & pathToHtml
If xml.parseError.ErrorCode <> 0 Then Debug.Print "Error when loading was: " + xml.parseError.reason
End If


Thanks in advance for any advice,

John

Can you preprocess the doc and open the XML file, deleting the line that is referring to a DTD location
– dbmitch
Jul 2 at 22:27

Any luck with trying the suggestion below?
– dbmitch
Jul 5 at 20:17

1 Answer
1

I think you can set the ValidateOnParse property to false – by default it is True.

ValidateOnParse

This property is used to specify whether the XML parser should validate (true) this document against document type definition (DTD), schema, or schema cache on loading. This property is supported in MSXML 6.0.

Just before your line

If xml.Load(pathToHtml) Then

If xml.Load(pathToHtml) Then

try adding the line:

xml.validateOnParse = False

xml.validateOnParse = False

More information on Microsoft’s site

By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

VBA – run-time error ‘424’ – object required – folderpicker

I need to run a loop through all excel files in a folder and copy/paste the data from those files into a existing spreadsheet. To open the folder I’m using the ‘msoFileDialogFolderPicker’ from FileDialog applications. I’ve been troubleshooting the runTimeError ‘424’ without success, & all research has led me to general info.
Any help would be greatly appreciated, & thanks in advance.

Here’s the program:

Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FlrdPicker As FileDialog
Dim RowN As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve target folder path from user

Set FlrdPicker = Appplication.FileDialog(msoFileDialogFolderPicker)

With FlrdPicker
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.FilePath("E:IPICS-REFINED")
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & ""
End With

NextCode:

myPath = myPath
myExtension = "*.xls*"
myFile = Dir(myPath & myExtension)

Do While myFile <> ""
Set wb = Workbooks.Open(Filename:=myPath & myFile)
DoEvents

'copy & paste data below last used row
Workbooks("IPIC-DATA.xlsx").Activate

RowN = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, 1).End(xlUp).Row
RowN = RowN + 10
Worksheets("DIMENSIONAL").Range("K2").Copy
Worksheets("Sheet1").Range("A" & RowN).PasteSpecial
wb.Close SaveChanges:=True
DoEvents

myFile = Dir
Loop

MsgBox "Data Gathered!"

End Sub


Please include the code as text and not a picture.
– Scott Craner
Jul 2 at 20:30

but right off you have an extra p in Appplication.FileDialog
– Scott Craner
Jul 2 at 20:31

p

Appplication.FileDialog

How should we copy your picture into the VB Editor for testing? Do you have a tool for that?
– Ron Rosenfeld
Jul 2 at 20:31

Sorry for the mishap. I put the code in. You can reference the JPEG for indents.
– Kwon Black
Jul 2 at 20:41

Removed the extra ‘p’ and that resolved the ‘424’
– Kwon Black
Jul 2 at 20:45

By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

Access VBA Version Check Front End

I am going to be splitting an Access database into a Front End (everything except tables) and Back End (tables only). I will put the Back End file on a network share and distribute the Front End file to each user so they have their own copy. When it comes time to update the Front End I would like a message to appear when they open their version to indicate it is out of date and hopefully prevent any access.

I was thinking of creating a table on the Front End and on the Back End that stores the version number of the Front End (e.g. 1.02). Then when I update the version of the Front End in the table on the Back End the old Front Ends will pop up a message and stop working.

So I created the tables and created a query to show the Front End version number in both the Front End version table and the Back End version table. Now how do I auto run this query and pop up a message and stop access when the version numbers are different???

Is there a better way???

Thank you in advance.

In theory, you could have the Access database automatically overwrite itself instead (using some sort of launcher), that way it would always be the most up-to-date version. But if you’re dead set on version checks, someone may have a better idea how to deal with that.
– Jiggles32
Jul 2 at 21:22

It is a great approach. In your main starutp code (or form), simply pull each value, and check the version numbers. Pop up a message that the application needs to be upgraded (or better yet, ASK the user if they want to upgrade). You can then simply shell out to a bat file that copies the new FE – and do a application.Quit to exist access (since you can’t overwrite the front end while you are running it). I usually run a vbs script, and in that script have one msgbox like “about to upgrade, yes/no" – as this prompt gives access time to exit and shutdown.
– Albert D. Kallal
Jul 3 at 1:54

you can create a small hidden form while opening the main form and than check that the version and if it is different than make that hidden form to visible and let your message display on it and you can also shutdown the access form when the fornd end is not a new version. you look here how to force shutdown all other access fornd end on the network . link
– Tarun. P
Jul 3 at 6:31

1 Answer
1

It is much simpler to use a shortcut to launch the application pulling a fresh copy each time from a networked distribution folder. On a modern network it takes a second or so, and the user will always have an updated and non-bloated copy.

All you need is a script. I wrote up once a full article on how to handle this even in a Citrix environment:

Deploy and update a Microsoft Access application in a Citrix environment

The script establishes two copies of the frontend. That you may not need, thus you can reduce the script somewhat:

Option Explicit

' Launch script for PPT test/development/operation.
' Version 1.3.0
' 2013-09-15
' Cactus Data. Gustav Brock

Const DESKTOP = &H10
Const LOCALAPPDATA = &H1C

Dim objFSO
Dim objAppShell
Dim objDesktopFolder
Dim objLocalAppDataFolder
Dim objLocalFolder
Dim objRemoteFolder

Dim strLocalFolder
Dim strRemoteFolder
Dim strDesktopFolder
Dim strLocalAppDataFolder
Dim strLocalAppDataDsgFolder
Dim strLocalAppDataDsgPptFolder
Dim strDsgSubfolder
Dim strPptSubfolder
Dim strPptAppSubfolder
Dim strPptNcSuffix
Dim strAppName
Dim strAppSuffix
Dim strShortcutName
Dim strAppLocalPath
Dim strAppLocalBackPath
Dim strAppRemotePath
Dim strShortcutLocalPath
Dim strShortcutRemotePath
Dim strRegPath
Dim strRegKey
Dim strRegValue
Dim booNoColour

Dim varValue

' Adjustable parameters.
strDsgSubfolder = "DSG"
strPptSubfolder = "PPT"
strPPtNcSuffix = "NC"
' ---------------------------------------------------------------------------------
' Uncomment one folder name only:
'strPptAppSubfolder = "Development"
strPptAppSubfolder = "Operations"
'strPptAppSubfolder = "Test"
' ---------------------------------
' Indicate if the script is for the normal version (0) or the no-colour version (1):
booNoColour = 0
' ---------------------------------------------------------------------------------
strRemoteFolder = "K:_SharedSales PlanningEnvironments" & strPptAppSubfolder
If booNoColour = 1 Then
strAppSuffix = strPptNcSuffix
Else
strAppSuffix = ""
End If
strAppName = "SalesPlanningTool" & strAppSuffix & ".accdb"
If strPptAppSubfolder = "Operations" Then
If strAppSuffix = "" Then
strShortcutName = "RunPPT.lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & ".lnk"
End If
Else
If strAppSuffix = "" Then
strShortcutName = "RunPPT " & strPptAppSubfolder & ".lnk"
Else
strShortcutName = "RunPPT " & strAppSuffix & " " & strPptAppSubfolder & ".lnk"
End If
End If

' Enable simple error handling.
On Error Resume Next

' Find user's Desktop and AppDataLocal folder.
Set objAppShell = CreateObject("Shell.Application")
Set objDesktopFolder = objAppShell.Namespace(DESKTOP)
strDesktopFolder = objDesktopFolder.Self.Path
Set objLocalAppDataFolder = objAppShell.Namespace(LOCALAPPDATA)
strLocalAppDataFolder = objLocalAppDataFolder.Self.Path

' Dynamic parameters.
strLocalAppDataDsgFolder = strLocalAppDataFolder & "" & strDsgSubfolder
strLocalAppDataDsgPptFolder = strLocalAppDataDsgFolder & "" & strPptSubfolder
strLocalFolder = strLocalAppDataDsgPptFolder & "" & strPptAppSubfolder
strAppLocalPath = strLocalFolder & "" & strAppName
strShortcutLocalPath = strDesktopFolder & "" & strShortcutName

' Permanent parameters.
strAppRemotePath = strRemoteFolder & "" & strAppName
strShortcutRemotePath = strRemoteFolder & "" & strShortcutName

' Create the File System Object.
Set objFSO = CreateObject("Scripting.FileSystemObject")

If Not objFSO.FolderExists(strRemoteFolder) Then
Call ErrorHandler("No access to " & strRemoteFolder & ".")
Else
Set objRemoteFolder = objFSO.GetFolder(strRemoteFolder)
' If local folder does not exist, create the folder.
If Not objFSO.FolderExists(strLocalFolder) Then
If Not objFSO.FolderExists(strLocalAppDataDsgFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalAppDataDsgPPtFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgPptFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalAppDataDsgPptFolder & " could not be created.")
End If
End If
If Not objFSO.FolderExists(strLocalFolder) Then
Set objLocalFolder = objFSO.CreateFolder(strLocalFolder)
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Folder " & strLocalFolder & " could not be created.")
End If
End If
End If
Set objLocalFolder = objFSO.GetFolder(strLocalFolder)
End If

If Not objFSO.FileExists(strAppRemotePath) Then
Call ErrorHandler("The application file:" & vbCrLf & strAppRemotePath & vbCrLF & "could not be found.")
Else
' Close a running PPT.
Call KillTask("PPT")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")
Call KillTask("PPT Background")
' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
Call AwaitProcess("taskkill.exe")

' Copy app to local folder.
If objFSO.FileExists(strAppLocalPath) Then
objFSO.DeleteFile(strAppLocalPath)
If Not Err.Number = 0 Then
Call ErrorHandler("The application file:" & vbCrLf & strAppName & vbCrLF & "can not be refreshed/updated. It may be in use.")
End If
End If
If objFSO.FileExists(strAppLocalPath) Then
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be replaced.")
Else
objFSO.CopyFile strAppRemotePath, strAppLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Application could not be copied to " & strLocalFolder & ".")
End If
' Create copy for PPT Background.
strAppLocalBackPath = Replace(Replace(strAppLocalPath, ".accdb", ".accbg"), "SalesPlanningTool", "SalesPlanningToolBack")
objFSO.CopyFile strAppLocalPath, strAppLocalBackPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Background application could not be copied to " & strLocalFolder & ".")
End If
End If

' Copy shortcut.
objFSO.CopyFile strShortcutRemotePath, strShortcutLocalPath
If Not Err.Number = vbEmpty Then
Call ErrorHandler("Shortcut could not be copied to your Desktop.")
End If
End If

' Write Registry entries for Access security.
strRegKey = "HKEY_CURRENT_USERSoftwareMicrosoftOffice14.0AccessSecurity"
strRegValue = "VBAWarnings"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue,"REG_DWORD")

strRegKey = strRegKey & "Trusted LocationsLocationLocalAppData"
strRegValue = "AllowSubfolders"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue, "REG_DWORD")

strRegValue = "Date"
strRegPath = strRegKey & strRegValue
varValue = Now
varValue = FormatDateTime(varValue, vbShortDate) & " " & FormatDateTime(varValue, vbShortTime)
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

strRegValue = "Description"
strRegPath = strRegKey & strRegValue
varValue = "Local AppData"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

strRegValue = "Path"
strRegPath = strRegKey & strRegValue
varValue = strLocalAppDataFolder & ""
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

' Run PPT.
If objFSO.FileExists(strAppLocalPath) Then
Call RunApp(strAppLocalPath, False)
Else
Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be found.")
End If

Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing

WScript.Quit

' Supporting subfunctions
' -----------------------

Sub RunApp(ByVal strFile, ByVal booBackground)

Dim objShell
Dim intWindowStyle

' Open as default foreground application.
intWindowStyle = 1

Set objShell = CreateObject("WScript.Shell")
objShell.Run Chr(34) & strFile & Chr(34), intWindowStyle, False
Set objShell = Nothing

End Sub

Sub KillTask(ByVal strWindowTitle)

Dim objShell

Set objShell = CreateObject("WScript.Shell")
objShell.Run "TaskKill.exe /FI ""WINDOWTITLE eq " & strWindowTitle & """", 7, False
Set objShell = Nothing

End Sub

Sub AwaitProcess(ByVal strProcess)

Dim objSvc
Dim strQuery
Dim colProcess
Dim intCount

Set objSvc = GetObject("winmgmts:rootcimv2")
strQuery = "select * from win32_process where name='" & strProcess & "'"

Do
Set colProcess = objSvc.Execquery(strQuery)
intCount = colProcess.Count
If intCount > 0 Then
WScript.Sleep 300
End If
Loop Until intCount = 0

Set colProcess = Nothing
Set objSvc = Nothing

End Sub

Sub WriteRegistry(ByVal strRegPath, ByVal varValue, ByVal strRegType)
' strRegType should be:
' "REG_SZ" for a string
' "REG_DWORD" for an integer
' "REG_BINARY" for a binary or boolean
' "REG_EXPAND_SZ" for an expandable string

Dim objShell

Set objShell = CreateObject("WScript.Shell")

Call objShell.RegWrite(strRegPath, varValue, strRegType)

Set objShell = Nothing

End Sub

Sub ErrorHandler(Byval strMessage)

Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing
WScript.Echo strMessage
WScript.Quit

End Sub


By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

ComboBox(number)_Change from generated ComboBoxes in VB

T he code below is what I am having some problems with. I’m pretty green to using Userforms in VB.

My goal is to create 3 ComboBoxes drawing data from the column of Vendors in the sheet “Vendor Bids" and 3 ListBoxes to select the vendor’s product.

For j = 1 To 3

Set myCombo = Frame1.Controls.Add("Forms.ComboBox.1", "ComboBox" & j)
Set myList = Frame1.Controls.Add("Forms.ListBox.1", "ListBox" & j)

With myList
.Top = 18 + (150 - 84) * (j - 1)
.Height = 34.85
.Left = 198
.Width = 180
MsgBox .Name
End With

With myCombo
.Top = 18 + (150 - 84) * (j - 1)
.Height = 22.8
.Left = 42
.Width = 132
End With

Set rData = ThisWorkbook.Worksheets("VendorBids").Range("A:A").CurrentRegion
Me.Controls("ComboBox" & j).List = rData.Offset(1).Value
Me.Controls("ListBox" & j).ColumnCount = 1
Me.Controls("ListBox" & j).List = rData.Offset(1, 1).Value

Next


This part works perfectly. The reason I have this coded and not made in the Userform is because I have a function to add another row of the Combo and List boxes when the user presses the commandbutton. It works perfectly as well.

The problem I am having is with ComboBox_Change(). If I create the combobox in the UserForm GUI editor then ComboBox1_Change() will work. Below is an example with what I’m trying to achieve but with all of the generated comboboxes, like ComboBox2, 3, and so on…

Private Sub ComboBox1_Change()

Me.ListBox1.ListIndex = Me.ComboBox1.ListIndex

End Sub


I apologize if I’m not very clear in my logic or explanations – this is something I’m working to improve on as a novice.

Possible duplicate of Subscribe to events in VBA?
– Ahmed Abdelhameed
Jul 2 at 20:14

1 Answer
1

Reference:Chip Pearson – Events And Event Procedures In VBA

You will need a combination of WithEvents and RaiseEvents to handle the events of the new controls.

WithEvents

RaiseEvents

Stores a reference to a single Combobox. Using WithEvents it notifies the ControlHandlerCollection when the ComboBox_Change().

ControlHandlerCollection

ComboBox_Change()

Option Explicit
Public ControlHandlerCollection As VBAProject.ControlHandlerCollection
Public WithEvents ComboBox As MSForms.ComboBox

Private Sub ComboBox_Change()
ControlHandlerCollection.ComboBoxChanged ComboBox
End Sub


Stores a reference to a single ListBox . Using WithEvents it notifies the ControlHandlerCollection when the ListBox_Change().

ControlHandlerCollection

ListBox_Change()

Option Explicit
Public ControlHandlerCollection As VBAProject.ControlHandlerCollection
Public WithEvents ListBox As MSForms.ListBox

Private Sub ListBox_Change()
ControlHandlerCollection.ListBoxChanged ListBox
End Sub


Holds a collection of both ComboBoxHandlers and ListBoxHandlers whenever one of the handler class notifies it of a change it raises an event to notify the Userform of the change.

ComboBoxHandlers

ListBoxHandlers

Private EventHandlers As New Collection

Public Event ComboBoxChange(ComboBox As MSForms.ComboBox)
Public Event ListBoxChange(ListBox As MSForms.ListBox)

Public Sub AddComboBox(ComboBox As MSForms.ComboBox)
Dim ComboBoxHandler As New ComboBoxHandler
Set ComboBoxHandler.ControlHandlerCollection = Me
Set ComboBoxHandler.ComboBox = ComboBox
EventHandlers.Add ComboBoxHandler
End Sub

Public Sub AddListBox(ListBox As MSForms.ListBox)
Dim ListBoxHandler As New ListBoxHandler
Set ListBoxHandler.ControlHandlerCollection = Me
Set ListBoxHandler.ListBox = ListBox
EventHandlers.Add ListBoxHandler
End Sub

Public Sub ComboBoxChanged(ComboBox As MSForms.ComboBox)
RaiseEvent ComboBoxChange(ComboBox)
End Sub

Public Sub ListBoxChanged(ListBox As MSForms.ListBox)
RaiseEvent ListBoxChange(ListBox)
End Sub


Option Explicit
Private WithEvents ControlHandlerCollection As ControlHandlerCollection

Private Sub ControlHandlerCollection_ComboBoxChange(ComboBox As MSForms.ComboBox)
MsgBox "Value: " & ComboBox.Value & vbNewLine & _
"Name: " & ComboBox.Name & vbNewLine & _
"Tag: " & ComboBox.Tag
End Sub

Private Sub ControlHandlerCollection_ListBoxChange(ListBox As MSForms.ListBox)
MsgBox "Value: " & ListBox.Value & vbNewLine & _
"Name: " & ListBox.Name & vbNewLine & _
"Tag: " & ListBox.Tag
End Sub

Private Sub UserForm_Initialize()
Set ControlHandlerCollection = New ControlHandlerCollection
End Sub

Private Sub btnAddRow_Click()
Dim j As Long
Dim rData As Range
Dim myCombo As MSForms.ComboBox, myList As MSForms.ListBox
Set rData = ThisWorkbook.Worksheets("VendorBids").Range("A:A").CurrentRegion

For j = 1 To 3

Set myCombo = Frame1.Controls.Add("Forms.ComboBox.1", "ComboBox" & j)
Set myList = Frame1.Controls.Add("Forms.ListBox.1", "ListBox" & j)

With myList
.Top = 18 + (150 - 84) * (j - 1)
.Height = 34.85
.Left = 198
.Width = 180
.ColumnCount = 1
.List = rData.Offset(1, 1).Value
.Tag = rData.Offset(1, 1).Address
End With

With myCombo
.Top = 18 + (150 - 84) * (j - 1)
.Height = 22.8
.Left = 42
.Width = 132
.List = rData.Offset(1).Value
.Tag = rData.Offset(1).Address
End With

ControlHandlerCollection.AddComboBox myCombo
ControlHandlerCollection.AddListBox myList
Next
End Sub


Thank you! It’s working 100% so far. Would you mind explaining more or pointing to some resources to learn more about WithEvents, RaiseEvents, and how collections work? I truly appreciate your help.
– nbatts
Jul 3 at 19:06

VBA – Handling events from an indefinite number of event sources explains it pretty well.
– TinMan
Jul 3 at 19:27

The is used collection to store references to the control handlers. Without the collection the control handlers would be cleaned up by the VBA Garbage Collector at the end of the subroutine.
– TinMan
Jul 3 at 19:36

WithEvents hookes the class into the control’s events that are exposed through Com. You can also create your own class events which will notify any class or userform that is monitoring your class’s events using WithEvents.
– TinMan
Jul 3 at 19:39

WithEvents

WithEvents

Ok so the ComboBox_Change() works for me perfectly. Now to get it what I want it to do. It has the all of the data of the ComboBox that was changed, specifically the name. The name is myCombo(number). It doesn’t have anything about which listbox is tied to it. So, to make it dynamic, I think i will 1. Parse name of myCombo(number) to only get the number. 2. Build a variable named (myList + number) where the number was parsed from the myCombo name. 3. Set new variable of myList(number).ListIndex = ComboBox.ListIndex Is there a more efficient or cleaner way to achieve this?
– nbatts
Jul 3 at 20:01

By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

VBA to compare two columns and copy row

In Excel I am trying to make a macro that checks for two criteria in a row and copy it to another page. This is what I have so far. If I take out all of the AK references it does work on the first variable but the second one is causing me grief. Any thoughts? thank you for your time in advance.

Sub GenMonthWeekend()
Dim aj As Range
Dim ak As Range
Dim abc As Integer
Dim Source As Worksheet
Dim Target As Worksheet

' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Month Raw Data")
Set Target = ActiveWorkbook.Worksheets("Month Volume - Weekend")

abc = 2 ' Start copying to row 2 in target sheet
For Each aj In Source.Range("aj1:ak10000") ' Do 10000 rows
If aj = "1" And ak = "False" Then ' If colum aj is 1 and ak false copy
Source.Rows(aj.Row).Copy Target.Rows(abc)
abc = abc + 1
ElseIf aj = "7" And ak = "False" Then ' If colum aj is 7 and ak false copy
Source.Rows(aj.Row).Copy Target.Rows(abc)
abc = abc + 1
End If
Next aj
End Sub


You are not setting a range to ak Just because it is named the column reference does not make vba automatically assign the range to it.
– Scott Craner
Jul 2 at 18:01

ak

Is False typed in or is it FALSE as in the acutual Boolean?
– Scott Craner
Jul 2 at 18:02

False

FALSE

False is typed in the box
– Robby Stolle
Jul 2 at 18:04

1 Answer
1

Your range variable ak is not working the way you think it is.

ak

Just loop through your column AJ and check the value in AK by using Offset(,1) which will look one column over to the right.

AJ

AK

Offset(,1)

abc = 2
For Each aj In Source.Range("AJ1000")
If aj = "1" And aj.offset(,1) = "False" Then
Source.Rows(aj.Row).Copy Target.Rows(abc)
abc = abc + 1
ElseIf aj = "7" And aj.offset(,1) = "False" Then
Source.Rows(aj.Row).Copy Target.Rows(abc)
abc = abc + 1
End If
Next aj


You can clean this up by combining your criteria and using a For i loop.

For i

Sub GenMonthWeekend()
Dim i As Range

Dim Source As Worksheet: Set Source = ActiveWorkbook.Worksheets("Month Raw Data")
Dim Target As Worksheet: Set Target = ActiveWorkbook.Worksheets("Month Volume - Weekend")

For i = 2 To 1000
If (Source.Range("AJ" & i) = 1 Or Source.Range("AJ" & i) = 7) And Source.Range("AJ" & i).Offset(, 1) = "False" Then
Source.Rows(i).Copy Target.Rows(Target.Range("A" & Target.Rows.Count).End(xlUp).Offset(1).Row)
End If
Next i

End Sub


Since the output is the same on the if and Elseif you can combine them: If (aj = "1" Or aj = "7") And aj.Offset(, 1) = "False" Then
– Scott Craner
Jul 2 at 18:04

If (aj = "1" Or aj = "7") And aj.Offset(, 1) = "False" Then

I was working on that right now and swapping this for an For i = 1 to 1000 loop. Just addressing the main issue before editing
– urdearboy
Jul 2 at 18:05

For i = 1 to 1000

GREAT SCOTT I OWE YOU A BEER! urdearboy thank you
– Robby Stolle
Jul 2 at 18:05

@RobbyStolle updated. May be worth while to check out a slightly cleaner approach. Easier to follow
– urdearboy
Jul 2 at 18:21

By clicking “Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.