I have a table that contains run numbers. This is then linked to a second table that contains the serial numbers of the panels that go through each run. I was wondering is it possible to design a query that will give for each run number the serial numbers.
I would like it in a table like:
Run Number1, First Serial Number for 1, Second Serial Number for 1, etc..
Run Number2, First Serial Number for 2, Second Serial Number for 2, etc..
I can get in in the form:
Run Number1, First Serial Number for 1
Run Number1, Second Serial Number for 1
Run Number2, First Serial Number for 2
Run Number2, Second Serial Number for 2
Is there a way to set this up?
You can use my DJoin function as this will accept SQL as the source, thus you won't need additional saved queries:
' Returns the joined (concatenated) values from a field of records having the same key.
' The joined values are stored in a collection which speeds up browsing a query or form
' as all joined values will be retrieved once only from the table or query.
' Null values and zero-length strings are ignored.
'
' If no values are found, Null is returned.
'
' The default separator of the joined values is a space.
' Optionally, any other separator can be specified.
'
' Syntax is held close to that of the native domain functions, DLookup, DCount, etc.
'
' Typical usage in a select query using a table (or query) as source:
'
' Select
' KeyField,
' DJoin("[ValueField]", "[Table]", "[KeyField] = " & [KeyField] & "") As Values
' From
' Table
' Group By
' KeyField
'
' The source can also be an SQL Select string:
'
' Select
' KeyField,
' DJoin("[ValueField]", "Select ValueField From SomeTable Order By SomeField", "[KeyField] = " & [KeyField] & "") As Values
' From
' Table
' Group By
' KeyField
'
' To clear the collection (cache), call DJoin with no arguments:
'
' DJoin
'
' Requires:
' CollectValues
'
' 2019-06-24, Cactus Data ApS, Gustav Brock
'
Public Function DJoin( _
Optional ByVal Expression As String, _
Optional ByVal Domain As String, _
Optional ByVal Criteria As String, _
Optional ByVal Delimiter As String = " ") _
As Variant
' Expected error codes to accept.
Const CannotAddKey As Long = 457
Const CannotReadKey As Long = 5
' SQL.
Const SqlMask As String = "Select {0} From {1} {2}"
Const SqlLead As String = "Select "
Const SubMask As String = "({0}) As T"
Const FilterMask As String = "Where {0}"
Static Values As New Collection
Dim Records As DAO.Recordset
Dim Sql As String
Dim SqlSub As String
Dim Filter As String
Dim Result As Variant
On Error GoTo Err_DJoin
If Expression = "" Then
' Erase the collection of keys.
Set Values = Nothing
Result = Null
Else
' Get the values.
' This will fail if the current criteria hasn't been added
' leaving Result empty.
Result = Values.Item(Criteria)
'
If IsEmpty(Result) Then
' The current criteria hasn't been added to the collection.
' Build SQL to lookup values.
If InStr(1, LTrim(Domain), SqlLead, vbTextCompare) = 1 Then
' Domain is an SQL expression.
SqlSub = Replace(SubMask, "{0}", Domain)
Else
' Domain is a table or query name.
SqlSub = Domain
End If
If Trim(Criteria) <> "" Then
' Build Where clause.
Filter = Replace(FilterMask, "{0}", Criteria)
End If
' Build final SQL.
Sql = Replace(Replace(Replace(SqlMask, "{0}", Expression), "{1}", SqlSub), "{2}", Filter)
' Look up the values to join.
Set Records = CurrentDb.OpenRecordset(Sql, dbOpenSnapshot)
CollectValues Records, Delimiter, Result
' Add the key and its joined values to the collection.
Values.Add Result, Criteria
End If
End If
' Return the joined values (or Null if none was found).
DJoin = Result
Exit_DJoin:
Exit Function
Err_DJoin:
Select Case Err
Case CannotAddKey
' Key is present, thus cannot be added again.
Resume Next
Case CannotReadKey
' Key is not present, thus cannot be read.
Resume Next
Case Else
' Some other error. Ignore.
Resume Exit_DJoin
End Select
End Function
' To be called from DJoin.
'
' Joins the content of the first field of a recordset to one string
' with a space as delimiter or an optional delimiter, returned by
' reference in parameter Result.
'
' 2019-06-11, Cactus Data ApS, Gustav Brock
'
Private Sub CollectValues( _
ByRef Records As DAO.Recordset, _
ByVal Delimiter As String, _
ByRef Result As Variant)
Dim SubRecords As DAO.Recordset
Dim Value As Variant
If Records.RecordCount > 0 Then
While Not Records.EOF
Value = Records.Fields(0).Value
If Records.Fields(0).IsComplex Then
' Multi-value field (or attachment field).
Set SubRecords = Records.Fields(0).Value
CollectValues SubRecords, Delimiter, Result
ElseIf Nz(Value) = "" Then
' Ignore Null values and zero-length strings.
ElseIf IsEmpty(Result) Then
' First value found.
Result = Value
Else
' Join subsequent values.
Result = Result & Delimiter & Value
End If
Records.MoveNext
Wend
Else
' No records found with the current criteria.
Result = Null
End If
Records.Close
End Sub
Full documentation can be found in my article:
Join (concat) values from one field from a table or query
If you don't have an account, browse to the link: Read the full article.
Code is also on GitHub: VBA.DJoin
Related
Is there a way to customize the code below (for making subscripts and superscripts larger) to search for superscript a , b, c …. and replace them with numbers 1, 2, 3 …in PowerPoint.
Any help would be much appreciated.
Source for the code.
Sub BumpTheSubsAndSupers()
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
Dim dBumpBy As Double
dBumpBy = 4 ' number of points to bump sub/superscript by
' Check each slide
For Each oSl In ActivePresentation.Slides
' Check each shape on the slide
For Each oSh In oSl.Shapes
' Make sure it's got text
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange
For x = 1 To .Runs.Count
If .Runs(x).Characters.Font.BaselineOffset <> 0 Then
' it's a sub/super; make it four points
' bigger than the text immediately prior:
.Runs(x).Characters.Font.Size = _
.Runs(x - 1).Characters.Font.Size + dBumpBy
End If ' it's a sub/superscript
Next x
End With ' textframe.textrange
End If ' .HasText
End If ' .HasTextFrame
Next oSh '
Next oSl
End Sub
Great question!
I've modified the code to do both (change the size and switch letters to numbers).
You can comment out whichever part you don't want if you like. There are doubtless more efficient ways of doing this (like splitting the array of letters once rather than once for each subscript) but it's all but instant on moderately sized files; the time it'd take to optimize it would probably exceed the time it'd save in use.
If you use letters from other alphabets as sub/superscripts, you'll want to add them to the OrdinalFromLetter function.
Option Explicit
Sub BumpTheSubsAndSupers()
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
Dim dBumpBy As Double
dBumpBy = 4 ' number of points to bump sub/superscript by
' Check each slide
For Each oSl In ActivePresentation.Slides
' Check each shape on the slide
For Each oSh In oSl.Shapes
' Make sure it's got text
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange
For x = 1 To .Runs.Count
If .Runs(x).Characters.Font.BaselineOffset <> 0 Then
' it's a sub/super; make it four points
' bigger than the text immediately prior:
.Runs(x).Characters.Font.Size = _
.Runs(x - 1).Characters.Font.Size + dBumpBy
.Runs(x).Text = CStr(OrdinalFromLetter(.Runs(x)))
End If ' it's a sub/superscript
Next x
End With ' textframe.textrange
End If ' .HasText
End If ' .HasTextFrame
Next oSh '
Next oSl
End Sub
Function OrdinalFromLetter(sLetter As String) As Long
Dim x As Long
Dim aLetters As Variant
aLetters = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z", ",")
For x = LBound(aLetters) To UBound(aLetters)
If UCase(sLetter) = aLetters(x) Then
OrdinalFromLetter = x
Exit Function
End If
Next
End Function
I'm new to VBA using regex. On a worksheet, I have a column with cells that have several specific names and between these names are several qualifiers. I need help to put together a VBA/macro code using regex to loop through the column and get the counts of the qualifiers between names and put the count value to the cell on the right of the name. The names all start with uppercase letters while the qualifiers start with a lower case letter. So i'm using ^[A-Z]* to match the names and ^[a-z]* for the qualifiers. Each value is in separate cells and the occurrences are random. So far I can only get total count of all qualifiers. I appreciate the help.
Like instead of RegEx
Adjust the values in the constants section.
Option Explicit
'START ****************************************************************** START'
' Title: Count Owners '
' Purpose: Counts the number of cells containing a string starting with '
' a lower-case character below a cell containing a string '
' starting with an upper-case character and writes the result '
' to the same row of the string starting with the upper-case '
' character, in another (specified) column. '
'******************************************************************************'
Sub CountOwners()
Const wsName As String = "Sheet1" ' Worksheet Name
Const rowHeader As Long = 3 ' Header Row
Const colOwner As Long = 2 ' Owner Column Number
Const colCount As Long = 3 ' Count Column Number
Dim rng As Range ' Owner Column, Owner Column Range,
' Count Column Range
Dim vntOwner As Variant ' Owner Array
Dim vntCount As Variant ' Count Array
Dim LneRinC As Long ' Last Non-Empty Row in Owner Column
Dim UB As Long ' Arrays Last Element Count
Dim lngOwner As Long ' Current Owner Element (Row)
Dim lngCount As Long ' (Current) Owner Count(er)
Dim i As Long ' First Arrays Element Counter
Dim j As Long ' Second Arrays Element Counter
Dim strChar As String * 1 ' Current Char
' IN WORKSHEET
' Define Owner Column.
Set rng = ThisWorkbook.Worksheets(wsName).Columns(colOwner)
' Using the Find method, try to define Owner Column Range.
Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
' Check if no data in Owner Column.
If rng Is Nothing Then GoTo NoData
' Calculate Last Non-Empty Row in Owner Column.
LneRinC = rng.Row
' Check if no Owners in Owner Column Range.
If LneRinC <= rowHeader Then GoTo NoOwners
' Define Owner Column Range.
Set rng = rng.Parent.Cells(rowHeader + 1, colOwner).Resize(LneRinC - rowHeader)
' Write values of Owner Column Range to Owner Array.
vntOwner = rng
' IN ARRAYS
' Define Arrays Last Element Count
UB = UBound(vntOwner)
' Resize Count Array (vntCount) to the size of Owner Array (vntOwner).
ReDim vntCount(1 To UB, 1 To 1)
' Loop through elements of Owner Array.
For i = 1 To UB
' Write first characterg of current element in Owner Array
' to Current Char.
strChar = Left$(vntOwner(i, 1), 1)
' Check if current char is an uppercase character.
If strChar Like "[A-Z]" Then
' Assign the value of the current row of Owner Array
' to Current Owner Element (Row).
lngOwner = i
' Reset Current Owner Element.
lngCount = 0
' Loop through the rest of the elements in Owner Array.
For j = i + 1 To UB
' Write first character of current element in Owner Array
' to Current Char.
strChar = Left$(vntOwner(j, 1), 1)
' Check if Current Char is an uppercase letter.
If strChar Like "[A-Z]" Then
' Reset First Arrays Element Counter.
i = j - 1
Exit For
Else
' Check if Current Char is a lowercase letter.
If strChar Like "[a-z]" Then
' Increase (Current) Owner Counter.
lngCount = lngCount + 1
End If
End If
Next
' Write value of (Current) Owner Counter to Count Array.
vntCount(lngOwner, 1) = lngCount
End If
Next
' IN WORKSHEET
' Define Count Column Range.
Set rng = rng.Offset(, colCount - colOwner)
' Write values of Count Array to Count Column Range.
rng = vntCount
ProgramError:
Exit Sub
NoData:
MsgBox "There is no data in Owner column (" & colOwner & ")."
GoTo ProgramError
NoOwners:
MsgBox "There are no Owners in Owner column (" & colOwner & ")."
GoTo ProgramError
End Sub
'******************************************************************************'
' Remarks: Values not starting with alpha characters are not counted. '
' Owner Column Range doesn't have to start with an Owner. '
' Owner Column Range can end with an Owner; the count will be 0. '
'END ********************************************************************** END'
Is there any way to use named groups with regular expressions in VBA?
I would like to write a an Excel VBA Sub that matches the dates in file names and decrements these dates by a specified amount. I need to be able to distinguish between dd/mm and mm/dd formats -- among other irregularities -- and using named groups something like this would solve the problem:
(?:<month>\d\d)(?:<day>\d\d)
Advice is appreciated
Nope, no named groups in VBScript regular expressions.
VBScript uses the same regexp engine that JScript uses, so it's compatible with JavaScript regex, which also doesn't have named groups.
You have to use unnamed groups and just go by the order they appear on the expression to retrieve them by index after running it.
In general, dd/mm and mm/dd can't be automatically distinguished since there are valid dates that could be either. (e.g. 01/04 could be January 4th or April 1st). I don't think you'd be able to solve this with a regular expression.
Here is an implementation of named groups using VBA I made today. Hopefully this will be useful to someone else!:
'Description:
' An implementation of Regex which includes Named Groups
' and caching implemented in VBA
'Example:
' Dim match as Object
' set match = RegexMatch("01/01/2019","(?<month>\d\d)\/(?<day>\d\d)\/(?<year>\d\d\d\d)")
' debug.print match("day") & "/" & match("month") & "/" & match("year")
'Options:
' "i" = IgnoreCase
'Return value:
' A dictionary object with the following keys:
' 0 = Whole match
' 1,2,3,... = Submatch 1,2,3,...
' "Count" stores the count of matches
' "<<NAME>>" stores the match of a specified name
Function RegexMatch(ByVal haystack As String, ByVal pattern As String, Optional ByVal options As String) As Object
'Cache regexes for optimisation
Static CachedRegex As Object
Static CachedNames As Object
If CachedRegex Is Nothing Then Set CachedRegex = CreateObject("Scripting.Dictionary")
If CachedNames Is Nothing Then Set CachedNames = CreateObject("Scripting.Dictionary")
'Named regexp used to detect capturing groups and named capturing groups
Static NamedRegexp As Object
If NamedRegexp Is Nothing Then
Set NamedRegexp = CreateObject("VBScript.RegExp")
NamedRegexp.pattern = "\((?:\?\<(.*?)\>)?"
NamedRegexp.Global = True
End If
'If cached pattern doesn't exist, create it
If Not CachedRegex(pattern) Then
'Create names/capture group object
Dim testPattern As String, oNames As Object
testPattern = pattern
testPattern = Replace(testPattern, "\\", "asdasd")
testPattern = Replace(testPattern, "\(", "asdasd")
'Store names for optimisation
Set CachedNames(options & ")" & pattern) = NamedRegexp.Execute(testPattern)
'Create new VBA valid pattern
Dim newPattern As String
newPattern = NamedRegexp.Replace(pattern, "(")
'Create regexp from new pattern
Dim oRegexp As Object
Set oRegexp = CreateObject("VBScript.RegExp")
oRegexp.pattern = newPattern
'Set regex options
Dim i As Integer
For i = 1 To Len(flags)
Select Case Mid(flags, i, 1)
Case "i"
oRegexp.ignoreCase = True
Case "g"
oRegexp.Global = True
End Select
Next
'Store regex for optimisation
Set CachedRegex(options & ")" & pattern) = oRegexp
End If
'Get matches object
Dim oMatches As Object
Set oMatches = CachedRegex(options & ")" & pattern).Execute(haystack)
'Get names object
Dim CName As Object
Set CName = CachedNames(options & ")" & pattern)
'Create dictionary to return
Dim oRet As Object
Set oRet = CreateObject("Scripting.Dictionary")
'Fill dictionary with names and indexes
'0 = Whole match
'1,2,3,... = Submatch 1,2,3,...
'"Count" stores the count of matches
'"<<NAME>>" stores the match of a specified name
For i = 1 To CName.Count
oRet(i) = oMatches(0).Submatches(i - 1)
If Not IsEmpty(CName(i - 1).Submatches(0)) Then oRet(CName(i - 1).Submatches(0)) = oMatches(0).Submatches(i - 1)
Next i
oRet(0) = oMatches(0)
oRet("Count") = CName.Count
Set RegexMatch = oRet
End Function
P.S. for a Regex library (built by myself) which has this additional functionality, check out stdRegex. The equivalent can be done with:
set match = stdRegex.Create("(?:<month>\d\d)(?:<day>\d\d)").Match(sSomeString)
Debug.print match("month")
There are also more features of stdRegex, than VBScript's standard object. See the test suite for more info.
Thanks #Sancarn for his code!
For a few reasons I've revised it. The changes I've made are documented inside the code:
' Procedure for testing 'RegexMatch'.
' - It shows how to convert a date from 'mm/dd/yyyy' to 'dd.mm.yyyy' format.
' - It shows how to retrieve named groups by real name: 'Match.Item("group name")'
' as well as by number: 'Match.Items(group number)'.
' - It shows how to retrieve unnamed groups by number-generated name as well as by number.
' - It shows how to retrieve group count and the whole match by number-generated name as well as by number.
' - It shows that non-capturing groups like '(?:y)?' won't be listed.
' - It shows that left parenthesis inside a character class like '([x(])?' won't disturbe.
' Take notice of:
' - the small difference between 'Item' and 'Items'
' - the quotes in 'Match.Item("number of an unnamed group")'
Sub TestRegexMatch()
Dim Match As Scripting.Dictionary
Set Match = RegexMatch("01/23/2019z", "(?<month>\d\d)\/([x(])?(?<day>\d\d)\/(?:y)?(?<year>\d\d\d\d)(z)?")
Debug.Print Match.Item("day") & "." & Match.Item("month") & "." & Match.Item("year") & " vs. " & Match.Items(2) & "." & Match.Items(0) & "." & Match.Items(3)
Debug.Print "'" & Match.Item("1") & "'" & ", '" & Match.Item("4") & "' vs. '" & Match.Items(1) & "', '" & Match.Items(4) & "'"
Debug.Print Match.Item("98") & " vs. " & Match.Items(Match.Count - 2)
Debug.Print Match.Item("99") & " vs. " & Match.Items(Match.Count - 1)
End Sub
' An implementation of regex which includes named groups and caching implemented in VBA.
' The 'Microsoft VBScript Regular Expressions 5.5' library must be referenced (in VBA-editor: Tools -> References).
' Parameters:
' - haystack: the string the regex is applied on.
' - originalPattern: the regex pattern with or without named groups.
' The group naming has to follow .net regex syntax: '(?<group name>group content)'.
' Group names may contain the following characters: a-z, A-Z, _ (underscore).
' Group names must not be an empty string.
' - options: a string that may contain:
' - 'i' (the regex will work case-insensitive)
' - 'g' (the regex will work globally)
' - 'm' (the regex will work in multi-line mode)
' or any combination of these.
' Returned value: a Scripting.Dictionary object with the following entries:
' - Item 0 or "0", 1 or "1" ... for the groups content/submatches,
' following the convention of VBScript_RegExp_55.SubMatches collection, which is 0-based.
' - Item Match.Count - 2 or "98" for the whole match, assuming that the number of groups is below.
' - Item Match.Count - 1 or "99" for number of groups/submatches.
' Changes compared to the original version:
' - Handles non-capturing and positive and negative lookahead groups.
' - Handles left parenthesis inside a character class.
' - Named groups do not count twice.
' E.g. in the original version the second named group occupies items 3 and 4 of the returned
' dictionary, in this revised version only item 1 (item 0 is the first named group).
' - Additional 'm' option.
' - Fixed fetching cached regexes.
' - Early binding.
' - Some code cleaning.
' For an example take a look at the 'TestRegexMatch' procedure above.
Function RegexMatch(ByVal haystack As String, ByVal originalPattern As String, Optional ByVal options As String) As Scripting.Dictionary
Dim GroupsPattern As String
Dim RealPattern As String
Dim RealRegExp As VBScript_RegExp_55.RegExp
Dim RealMatches As VBScript_RegExp_55.MatchCollection
Dim ReturnData As Scripting.Dictionary
Dim GroupNames As VBScript_RegExp_55.MatchCollection
Dim Ctr As Integer
' Cache regexes and group names for optimisation.
Static CachedRegExps As Scripting.Dictionary
Static CachedGroupNames As Scripting.Dictionary
' Group 'meta'-regex used to detect named and unnamed capturing groups.
Static GroupsRegExp As VBScript_RegExp_55.RegExp
If CachedRegExps Is Nothing Then Set CachedRegExps = New Scripting.Dictionary
If CachedGroupNames Is Nothing Then Set CachedGroupNames = New Scripting.Dictionary
If GroupsRegExp Is Nothing Then
Set GroupsRegExp = New VBScript_RegExp_55.RegExp
' Original version: GroupsRegExp.Pattern = "\((?:\?\<(.*?)\>)?"
GroupsRegExp.Pattern = "\((?!(?:\?:|\?=|\?!|[^\]\[]*?\]))(?:\?<([a-zA-Z0-9_]+?)>)?"
GroupsRegExp.Global = True
End If
' If the pattern isn't cached, create it.
If Not CachedRegExps.Exists("(" & options & ")" & originalPattern) Then
' Prepare the pattern for retrieving named and unnamed groups.
GroupsPattern = Replace(Replace(Replace(Replace(originalPattern, "\\", "X"), "\(", "X"), "\[", "X"), "\]", "X")
' Store group names for optimisation.
CachedGroupNames.Add "(" & options & ")" & originalPattern, GroupsRegExp.Execute(GroupsPattern)
' Create new VBScript regex valid pattern and set regex for this pattern.
RealPattern = GroupsRegExp.Replace(originalPattern, "(")
Set RealRegExp = New VBScript_RegExp_55.RegExp
RealRegExp.Pattern = RealPattern
' Set regex options.
For Ctr = 1 To Len(options)
Select Case Mid(options, Ctr, 1)
Case "i"
RealRegExp.IgnoreCase = True
Case "g"
RealRegExp.Global = True
Case "m"
RealRegExp.MultiLine = True
End Select
Next
' Store this regex for optimisation.
CachedRegExps.Add "(" & options & ")" & originalPattern, RealRegExp
End If
' Get matches.
Set RealMatches = CachedRegExps.Item("(" & options & ")" & originalPattern).Execute(haystack)
' Get group names.
Set GroupNames = CachedGroupNames.Item("(" & options & ")" & originalPattern)
' Create dictionary to return.
Set ReturnData = New Scripting.Dictionary
' Fill dictionary with names and indexes as descibed in the remarks introducing this procedure.
For Ctr = 1 To GroupNames.Count
If IsEmpty(GroupNames(Ctr - 1).SubMatches(0)) Then
ReturnData.Add CStr(Ctr - 1), RealMatches(0).SubMatches(Ctr - 1)
Else
ReturnData.Add GroupNames(Ctr - 1).SubMatches(0), RealMatches(0).SubMatches(Ctr - 1)
End If
Next
ReturnData.Add "98", RealMatches.Item(0)
ReturnData.Add "99", GroupNames.Count
' Return the result.
Set RegexMatch = ReturnData
End Function
For further improvement this code could be the base of a class module for replacement of the VBScript regex.
I have a problem which is giving me a headache. I really thought someone would have asked this already, but days of reading and testing has been fruitless.
I have a text file which starts:
"Determining profile based on KDBG search...
Suggested Profile(s) : WinXPSP2x86, WinXPSP3x86 (Instantiated with WinXPSP2x86)"
(The blank line between the two is not an error and neither are the spaces before 'Suggested')
I need to read the line starting 'Suggested...' only and extract every unique word starting 'Win' and populate a combobox with them. (i.e. 'WinXPSP2x86' and 'WinXPSP3x86')
I know i need to use the 'StreamReader' class and probably get a Regex going on, but, as a beginner, connecting it all together is beyond my knowledge at the moment.
Can anyone help? It would be much appreciated.
Imports System.IO
Public Class Form1
Private Sub Form1_Load( sender As Object, e As EventArgs) Handles MyBase.Load
' BASIC is case sensitive and e is parameter so we will start
' new variables with the letter f.
' Read all lines of file into string array F.
Dim F As String() = File.ReadAllLines("H:\Projects\35021241\Input.txt")
' F() is a 0 based array. Assign 3 line of file to G.
Dim G As String = F(2)
' On line 3 of file find starting position of the word 'win' and assign to H.
' TODO: If it is not found H will be -1 and we should quit.
Dim H As Integer = G.IndexOf("Win")
' Assign everything beginning at 'win' on line 3 to variable I.
Dim I As String = G.Substring(H)
' The value placed in delimiter will separate remaining values in I.
' Place C after ending quote to represent a single character as opposed to a string.
Dim Delimiter As Char = ","C
' J array will contain values left in line 3.
Dim J As String() = I.Split(Delimiter)
' Loop through J array removing anything in parenthesis.
For L = J.GetLowerBound(0) to J.GetUpperBound(0)
' Get location of open parenthesis.
Dim ParenBegin As Integer = J(L).IndexOf("(")
' If no open parenthesis found continue.
If ParenBegin <> -1 then
' Open parenthesis found. Find closing parenthesis location
' starting relative to first parenthesis.
Dim Temp As String = J(L).Substring(ParenBegin+1)
' Get location of ending parenthesis.
Dim ParenEnd As Integer = Temp.IndexOf(")")
' TODO: Likely an exception will be thrown if no ending parenthesis.
J(L) = J(L).Substring(0,ParenBegin) & J(L).Substring(ParenBegin + ParenEnd +2)
' Change to include text up to open parenthesis and after closing parenthesis.
End If
Next L
' UnwantedChars contains a list of characters that will be removed.
Dim UnwantedChars As String = ",()"""
' Check each value in J() for presence of each unwanted character.
For K As Integer = 0 to (UnwantedChars.Length-1)
For L = J.GetLowerBound(0) To J.GetUpperBound(0)
' Declare M here so scope will be valid at loop statement.
Dim M As Integer = 0
Do
' Assign M the location of the unwanted character or -1 if not found.
M= J(L).IndexOf(UnwantedChars.Substring(K,1))
' Was this unwanted character found in this value?
If M<>-1 Then
' Yes - where was it found in the value?
Select Case M
Case 0 ' Beginning of value
J(L) = J(L).Substring(1)
Case J(L).Length ' End of value.
J(L) = J(L).Substring(0,(M-1))
Case Else ' Somewhere in-between.
J(L) = J(L).Substring(0,M) & J(L).Substring(M+1)
End Select
Else
' No the unwanted character was not found in this value.
End If
Loop Until M=-1 ' Go see if there are more of this unwanted character in the value.
Next L ' Next value.
Next K ' Next unwanted character.
' Loop through all the values and trip spaces from beginning and end of each.
For L As Integer = J.GetLowerBound(0) To J.GetUpperBound(0)
J(L) = J(L).Trim
Next L
' Assign the J array to the combobox.
ComboBox1.DataSource = J
End Sub
End Class
As some have already suggested:
Use System.IO.File.ReadAllLines, if the file is not too big
Iterate through the array of lines
For each line, use the Split method to split on space
Check the first three characters of each word
This works but does of course need some error checking etc:
Dim lines() As String = System.IO.File.ReadAllLines("c:\temp\example.txt")
Dim lineWords() As String
For Each line As String In lines
lineWords = line.Split(New Char() {" "}, System.StringSplitOptions.RemoveEmptyEntries)
For Each word As String In lineWords
If word.Length > 3 Then
If word.Substring(0, 3).ToUpper = "WIN" Then
cmbWords.Items.Add(word)
End If
End If
Next
Next
I'm trying to extract date/times from strings with the following patterns and convert them to date types in Access.
"08-Apr-2012 21:26:49"
"...Confirmed by SMITH, MD, JOHN (123) on 4/2/2012 11:11:01 AM;"
Can anyone help?
Try this
Dim d As Date
d = CDate("08-Apr-2012 21:26:49")
Debug.Print Format(d, "dd-MMM-yyyy")
Debug.Print Format(d, "h:m:s")
Will give
08-Apr-2012
21:26:49
use this regex to get date-time between " on " (ie, space on space) and the ";" (first semi-colon after that).
(?<=\ on )(.*?)(?=\;)
As already mentioned by Romeo in his answer, you need to use CDate() to convert a string with a valid date value to a Date variable.
You can get the date value out of the string like this:
(given that the strings always look like the one in the example, " on " (with blanks) before the date and ";" after it):
Public Function Test()
Dim Source As String
Dim Tmp As String
Dim DateStart As Integer
Dim DateEnd As Integer
Dim DateValue As Date
Source = "...Confirmed by SMITH, MD, JOHN (123) on 4/2/2012 11:11:01 AM;"
'find the place in the source string where " on " ends
DateStart = InStr(1, Source, " on ") + 4
'find first semicolon after the date)
DateEnd = InStr(DateStart, Source, ";")
'get the part with the date
Tmp = Mid(Source, DateStart, DateEnd - DateStart)
'convert to date
DateValue = CDate(Tmp)
End Function
Add this function to a VBA module:
' ----------------------------------------------------------------------'
' Return a Date object or Null if no date could be extracted '
' ----------------------------------------------------------------------'
Public Function ExtractDate(value As Variant) As Variant
If IsNull(value) Then
ExtractDate = Null
Exit Function
End If
' Using a static, we avoid re-creating the same regex object for every call '
Static regex As Object
' Initialise the Regex object '
If regex Is Nothing Then
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = True
.IgnoreCase = True
.MultiLine = True
.pattern = "(\d+\/\d+/\d+\s+\d+:\d+:\d+\s+\w+|\d+-\w+-\d+\s+\d+:\d+:\d+)"
End With
End If
' Test the value against the pattern '
Dim matches As Object
Set matches = regex.Execute(value)
If matches.count > 0 Then
' Convert the match to a Date if we can '
ExtractDate = CDate(matches(0).value)
Else
' No match found, jsut return Null '
ExtractDate = Null
End If
End Function
And then use it like this, for instance in a query:
SELECT ID, LogData, ExtractDate(LogData) as LogDate
FROM MyLog
Make sure you check that hte dates returned are in the proper format and make sense to you.
CDate() interprets the date string in different ways depending on your locale.
If you're not getting the desired result, you will need to modify the code to separate the individual components of the date and rebuild them using DateSerial() for instance.