I am looking to clean up a .csv file for a database import. I am using the following vbs function and would like to incorporate '' to vbNull. I find it hard to understand RegEx. Can this even be done?
Function removeEmbeddedCommasInCSVTextField (strtoclean)
Dim objRegExp, outputStr
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = """[^""]*,[^""]*"""
Set objMatch = objRegExp.Execute( strtoclean )
corrected_row = strtoclean
For Each myMatch in objMatch
matched_value = myMatch.Value ' retrieves text column with embedded commas
cleaned_value = replace(matched_value, ",","") ' removes embeddes commans from column
corrected_row = replace(corrected_row, matched_value, cleaned_value) 'take row and replaced bad value with good value (no commas)
Next
removeEmbeddedCommasInCSVTextField = corrected_row
End Function
MAIN:
Set MyFile = fso.CreateTextFile(strShareDirectory & "fixed.txt", True)
Set f = fso.OpenTextFile(strShareDirectory & filename)
Do Until f.AtEndOfStream
before_clean = f.ReadLine
after_clean = removeEmbeddedCommasInCSVTextField(before_clean)
MyFile.WriteLine(after_clean)
'WScript.Echo after_clean
Loop
f.Close
MyFile.Close
Related
I'm currently having difficulty with a VBScript I'm writing that contains several read and replaces from a text file. The expression I'm using finds the expression and replaces it, but adds three tab spaces afterwords, making the original line below it mess up the formatting. Here's a picture of what I'm talking about:
Here's a pastebin of the before and after, rather than an image:
https://pastebin.com/Uw3H59QK
Here's my RegExp code:
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strPath
strPath = SelectFolder( "" )
If strPath = vbNull Then
WScript.Echo "Script Cancelled - No files have been modified" 'if the user cancels the open folder dialog
Else
WScript.Echo "Selected Folder: """ & strPath & """" 'prompt that tells you the folder you selected
End If
Function SelectFolder( myStartFolder )
Dim objFolder, objItem, objShell
Dim objFolderItems
On Error Resume Next
SelectFolder = vbNull
Set objShell = CreateObject( "Shell.Application" )
Set objFolder = objShell.BrowseForFolder( 0, "Please select the .dat file location folder", 0, myStartFolder)
set objFolderItems = objFolder.Items
If IsObject( objFolder ) Then SelectFolder = objFolder.Self.Path
Set objFolder = Nothing
Set objShell = Nothing
On Error Goto 0
End Function
Set re = New RegExp 'Replacing Position Lines
re.Pattern = "Pos = \((.*)\)"
re.Global = True
re.IgnoreCase = True
For Each f in fso.GetFolder(strPath).Files
If LCase(fso.GetExtensionName(f.Name)) = "txt" Then
text = f.OpenAsTextStream.ReadAll 'reading the text file
f.OpenAsTextStream(2).Write re.Replace(text, """Position"" : mathutils.Vector(($1)),")
count = count + 1
End If
Next
Set reAngles = New RegExp 'Replacing Angles
reAngles.Pattern = "Angles = \((.*)\)"
reAngles.Global = True
reAngles.IgnoreCase = True
For Each f in fso.GetFolder(strPath).files
If LCase(fso.GetExtensionName(f.Name)) = "txt" Then
text = f.OpenAsTextStream.ReadAll
f.OpenAsTextStream(2).Write reAngles.Replace(text, """Angles"" : mathutils.Vector(($1)),")
End If
Next
Set reNames = New RegExp 'Replacing Names
reNames.Pattern = "Name = (.*)"
reNames.Global = True
'reNames.Multiline = True
reNames.IgnoreCase = True
For Each f in fso.GetFolder(strPath).files
If LCase(fso.GetExtensionName(f.Name)) = "txt" Then
text = f.OpenAsTextStream.ReadAll
f.OpenAsTextStream(2).Write reNames.Replace(text, """Name"" : ""$1"",")
End If
Next
My best guess is that the wildcard is grabbing more info than needed...but I'm unsure how to fix that. I used a lot of these expressions in Notepad++ so I was hoping to translate them to a VBS easily!
I'm trying to use negative lookback to match all dates without an asterisk in front but it doesn't seem to be working.
(?<!\\*)(\b(?:0[1-9]|[0-2])/(?:0[1-9]|[12]\d|3[01])/(?:19\d{2}|[2-9]\d{3})\b)
This is the string I'm trying to match:
02/02/2019 *03/20/2019 AB CART 9000341 FAXED TO INSTITUTION
Here's the full code for what I have. It extracts the most recent date preceding the word faxed. The problem is if there is a date with an asterisk in front of it (such as *03/20/2019) it chooses that instead of the date (02/02/2019)
This is the Function:
Option Explicit
Function lastFaxedDt(s As String) As Date
Dim re As RegExp, MC As MatchCollection
Const sPat As String = "(\b(?:0[1-9]|1[0-2])/(?:0[1-9]|[12]\d|3[01])/(?:19\d{2}|[2-9]\d{3})\b)(?=.*?faxed)"
Set re = New RegExp
With re
.Pattern = sPat
.IgnoreCase = True
.Global = True
If .Test(s) = True Then
Set MC = .Execute(s)
lastFaxedDt = CDate(MC(MC.Count - 1))
End If
End With
End Function
This is the Macro:
Sub ExtractDate()
marker = 0
Set objShell = CreateObject("Shell.Application")
IE_count = objShell.Windows.Count
For x = 0 To (IE_count - 1)
On Error Resume Next
my_url = objShell.Windows(x).document.Location
my_title = objShell.Windows(x).document.Title
If my_title Like "RFT" & "*" Then
Set IE = objShell.Windows(x)
marker = 1
Exit For
Else
End If
Next
Dim Text As String
Text = Trim$(IE.document.getElementById("ctl00_ContentPlaceHolder1_txtNotes").innerText)
ExtractedDate = lastFaxedDt(Text)
If ExtractedDate = "12:00:00 AM" Then
ExtractedDate = "0"
Else
End If
ExtractedDate = CLng(ExtractedDate)
MaxDate = Application.WorksheetFunction.Max(ExtractedDate)
If MaxDate = "0" Then
MsgBox "No Date Found"
Else
End If
MaxDate = CDate(MaxDate)
Dim ws5 As Worksheet: Set ws5 = ActiveWorkbook.ActiveSheet
ws5.Range("C" & (ActiveCell.Row)).Value = MaxDate
Range("C" & (ActiveCell.Row)).NumberFormat = "[$-409]d-mmm;#"
End Sub
As mentioned in the comments, VBA does not support Lookbehinds. To work around this, you can replace your Lookbehind with the following:
(?:^|[^*])
And then find the date in the capturing group (sub-match) instead of the full match. In this case, your function should look something like this:
Function lastFaxedDt(s As String) As Date
Const sPat As String = _
"(?:^|[^*])" & _
"(\b(?:0[1-9]|1[0-2])/(?:0[1-9]|[12]\d|3[01])/(?:19\d{2}|[2-9]\d{3})\b)" & _
"(?=.*?faxed)"
Dim re As New RegExp, matches As MatchCollection
With re
.Pattern = sPat
.IgnoreCase = True
.Global = True
Set matches = .Execute(s)
If matches.Count > 0 Then
Dim lastMatch As Match: Set lastMatch = matches(matches.Count - 1)
lastFaxedDt = CDate(lastMatch.SubMatches.Item(0))
Else
' TODO: handle the case where no matches are found
End If
End With
End Function
Usage:
Dim s As String
s = "02/02/2019 *03/20/2019 AB CART 9000341 FAXED TO INSTITUTION"
MsgBox lastFaxedDt(s) ' 02/02/2019
I am trying to get the text right after - Map in this case example it is "AVE_NMHG_I_214_4010_XML_SAT" and input that into each Map Name row within the column up until the next space character found in could end up being "AVE_I_214_4010" as another example.
this is where I'm trying to make this fit.
Dim tmp As String
Dim RegX2 As Object, Mats1 As Object
tmp = strColS
Set RegX2 = CreateObject("VBScript.RegExp")
With RegX2
.Global = True
.Pattern = "Map\d{7}"
Set Mats1 = .Execute(tmp)
End With
If (RegX2.Test(tmp)) Then
Set Mats1 = RegX2.Execute(tmp)
tmp = Mats1(0)
Else
With RegX2
.Pattern = "MAP\d{9}"
Set Mats1 = .Execute(tmp)
End With
If (RegX.Test(tmp)) Then
tmp = Mats1(0)
End If
End If
Set Mats1 = Nothing
Set RegX2 = Nothing
Note: there isn't always a Map specified and sometimes it is defined as MAP or map.
This code works by selecting the emails in outlook and then running the macro for only that selected emails.
This is an example of a subject that has the
Example Subject
RE: TS001889493 - Translation failure - Inbound - ( VEXP/ HONCE/ Document Type 214 - Map AVE_NMHG_I_214_4010_XML_SAT - Error Conditional Relationship Error in N103 (0066) [ ref:_00D50c9MW._5000z1J3cG8:ref ]
Example of body
Dear Valued Trading Partner,
We received the attached 214 transactions from Sender ID: VEXP/ Receiver ID: HONCE that failed due to Conditional Relationship Error in the N1_03 (0066).
As per the map logic, If either N103 or N104 is present, then the other is required as they are in conditional relationship with each other. But in the input file received, N104 value is missing hence the error.
Transaction Details: #4# Attached
Please correct and resend the data.
Thank you, Simon Huggs | Sass support - Basic
What happens in the #num# is that it gets the sum of all these after making a match of the "TS" ticket ID.
This is the code I have up until now
Option Explicit
Sub WritingTicketNumberAndfailuresnew()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount, STicket, SticketNumber As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath, SSubject As String
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColS, strColB, sassupport, sMailDateReceived, SFrom As String
Dim Actions1, Actions2, Actions3, Actions4 As Boolean
Dim I, cnt, email_needed As Integer
' Get Excel set up
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open a specific workbook to input the data the path of the workbook under the windows user account
enviro = CStr(Environ("USERPROFILE"))
strPath = enviro & "\Documents\topthreeticket.xlsx"
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
' Add column names
xlSheet.Range("A1") = "Email Subject"
xlSheet.Range("B1") = "Map Name"
xlSheet.Range("C1") = "Case Number"
xlSheet.Range("D1") = "No. Of Failures"
xlSheet.Range("E1") = "Date"
xlSheet.Range("F1") = "Week Number"
sassupport = "sassuport#sass.com"
On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'collect the fields for ticket number and failure count
strColS = olItem.Subject
strColB = olItem.Body
SFrom = olItem.SenderEmailAddress
sMailDateReceived = olItem.ReceivedTime
Dim sFailures, stmp1, stmp2, stmp3 As String
Dim RegX As Object, Mats As Object
Dim Found As Boolean
' Check the number of failures from body
sFailures = "0"
stmp1 = strColB
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Global = True
.Pattern = "#\d+#"
Set Mats = .Execute(stmp1)
End With
If (RegX.Test(stmp1)) Then
stmp2 = Mats(0)
Found = True
stmp3 = Mid(stmp2, 2, Len(stmp2) - 2)
sFailures = stmp3
Else
With RegX
.Pattern = "#d\d+"
Set Mats = .Execute(stmp1)
End With
If (RegX.Test(stmp1)) Then
stmp2 = Mats(0)
Found = True
stmp3 = Mid(stmp2, 2, Len(stmp2) - 1)
sFailures = stmp3
End If
End If
Set Mats = Nothing
Set RegX = Nothing
Dim tmp As String
Dim RegX2 As Object, Mats1 As Object
tmp = strColS
Set RegX2 = CreateObject("VBScript.RegExp")
With RegX2
.Global = True
.Pattern = "Map\d{7}"
Set Mats1 = .Execute(tmp)
End With
If (RegX2.Test(tmp)) Then
Set Mats1 = RegX2.Execute(tmp)
tmp = Mats1(0)
Else
With RegX2
.Pattern = "MAP\d{9}"
Set Mats1 = .Execute(tmp)
End With
If (RegX.Test(tmp)) Then
tmp = Mats1(0)
End If
End If
Set Mats1 = Nothing
Set RegX2 = Nothing
Dim tempticketnum, tmpdate As String
Dim ticketnumposition As Integer
'write them in the excel sheet
If SFrom = sassupport Then
xlSheet.Range("A" & rCount) = strColS
xlSheet.Range("B" & rCount) = tmp2
xlSheet.Range("C" & rCount) = tmp
xlSheet.Range("D" & rCount) = sFailures ' number of failures
xlSheet.Range("E" & rCount) = sMailDateReceived
rCount = rCount + 1
End If
Next
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlSheet = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
To extract the substring as you specify:
.ignorecase = True
.pattern = "map\s*(\S+)"
or
.pattern = "\bmap\s*(\S+)"
The substring will be in capturing group 1
If there is no map then the .test(..) line will return False
Regex Explained
\bmap\s*(\S+)
Options: Case insensitive; ^$ don’t match at line breaks
Assert position at a word boundary \b
Match the character string “map” literally map
Match a single character that is a “whitespace character” \s*
Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
Match the regex below and capture its match into backreference number 1 (\S+)
Match a single character that is NOT a “whitespace character” \S+
Between one and unlimited times, as many times as possible, giving back as needed (greedy) +
Created with RegexBuddy
I have text file containing line starts with mmrk.
I want to extract all lines and write output.
I am trying following code. (I know this is not correct method, Just to show what I want.)
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fso, MyFile, FileName, Text
dim oFile, strPath
Set fso = CreateObject("Scripting.FileSystemObject")
FileName = "C:\Users\user\Desktop\2.rtf"
strPath = "C:\Users\user\Desktop\1.txt"
Set MyFile = fso.OpenTextFile(FileName, ForReading)
Do While MyFile.AtEndOfStream <> True
Text = MyFile.ReadAll
Loop
Set regEx_ = new regExp
With regEx_
.Global = True
.MultiLine = True
.IgnoreCase = True
'Do some regex find and replace(works perfectly)
.Pattern = "mmrk.*"
If regEx_.Test(Text) Then
Set oFile = fso.OpenTextFile(strPath, 2, True, -1)
oFile.Write Text
oFile.Close
End If
End With
MyFile.Close
Edit
I need to get lines from string.
I am currently first saving temp file from string and use Nefariis's answer to do the rest. Is there any direct method.
I think there are easier ways of doing this that do not involve a regex.
In VBScript:
FileName = "C:\Users\user\Desktop\2.rtf"
strPath = "C:\Users\user\Desktop\1.txt"
Set inFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(FileName)
Set outFile = CreateObject("Scripting.FileSystemObject").CreateTextFile(strPath,True)
Do Until inFile.AtEndOfStream
Dim line : line = inFile.Readline
If inStr(line, "mmrk.") = 1 then outFile.writeLine(line)
Loop
inFile.Close
outFile.Close
In VB.Net
Dim inFile as String() = File.ReadAllLines("inFileName")
Dim sw As StreamWriter = New StreamWriter("OutFileName", True)
For Each line As String In inFile
If line.StartsWith("mmrk.") Then sw.WriteLine(line)
Next
sw.Close()
This reads the file in, then goes through it looking for lines the start with "mmrk.", and saves the line into a seperate text file that you specifiy.
Looking for some help with my macro that loops through subfolders and brings back data from the workbooks that match my filename pattern, because the name changes each month.
It works seamlessly if the pattern is "[0-9][0-9][0-9][0-9][0-9][0-9] Filename"
But fails if "[0-9][0-9][0-9][0-9]_[0-9][0-9] Filename"
Any ideas on how to handle the underscore please?
This fails "[0-9][0-9][0-9][0-9][_][0-9][0-9] Filename"
Thanks heaps
GWS
Option Explicit
Option Base 1
Private Const PORTFOLIO_CODE As String = "G030"
Private Sub ExtractData()
' get workbook list
Dim wbList As Collection
Set wbList = New Collection
Application.DisplayAlerts = False
RecursiveFileSearch _
"O:\Sales and Marketing\Monthly Reports\", _
"[0-9][0-9][0-9][0-9][_][0-9][0-9] Monthly Report.xlsm", _ 'fails to find any workbooks
'"[0-9][0-9][0-9][0-9][0-9][0-9] Monthly Report.xlsm", _ 'would work except my file names contain underscores
wbList
Dim resultOffset As Integer
wsResult.Name = result
resultOffset = 1
Dim wbName As Variant, wbOpen As Workbook, wsFund As Worksheet
For Each wbName In wbList
' loop through workbook list
' - open workbook, hidden
Application.ScreenUpdating = False
Set wbOpen = Workbooks.Open(Filename:=wbName, ReadOnly:=True)
wbOpen.Windows(1).Visible = False
' - get worksheet for fund
Set wsFund = wbOpen.Worksheets(PORTFOLIO_CODE)
Application.ScreenUpdating = True
' - find top of data
Dim valueDate As Date
valueDate = WorksheetFunction.EoMonth(DateSerial(2000 + CInt(Left(wbOpen.Name, 2)), CInt(Mid(wbOpen.Name, 3, 2)), 1), 0)
Debug.Print valueDate, wbOpen.Name
ThisWorkbook.Worksheets(PORTFOLIO_CODE).Activate
Dim baseData As Excel.Range
Set baseData = wsFund.Range("AQ:AQ").Find("Currency")
If Not baseData Is Nothing Then
' - loop through data
Dim rowOffset As Integer
rowOffset = 0
wsResult.Range("A1").Offset(resultOffset, 0).Value = valueDate ' baseData.Offset(rowOffset, 0).Value
wsResult.Range("A1").Offset(resultOffset, 1).Value = baseData.Offset(rowOffset, 0).Value
wsResult.Range("A1").Offset(resultOffset, 2).Value = baseData.Offset(rowOffset, 5).Value
resultOffset = resultOffset + 1
End If
' - close workbook
wbOpen.Close SaveChanges:=False
DoEvents
Next
Application.DisplayAlerts = True
End Sub
RecursiveFileSearch
Sub RecursiveFileSearch( _
ByVal targetFolder As String, _
ByRef filePattern As String, _
ByRef matchedFiles As Collection _
)
Dim oRegExp As New VBScript_RegExp_55.RegExp
oRegExp.Global = False
oRegExp.IgnoreCase = True
oRegExp.MultiLine = False
oRegExp.Pattern = filePattern
Dim oFSO As Scripting.FileSystemObject
Set oFSO = New Scripting.FileSystemObject
'Get the folder oect associated with the target directory
Dim oFolder As Variant
Set oFolder = oFSO.GetFolder(targetFolder)
'Loop through the files current folder
Dim oFile As Variant
For Each oFile In oFolder.Files
If oRegExp.test(oFile.Name) Then
matchedFiles.Add oFile
End If
Next
'Loop through the each of the sub folders recursively
Dim oSubFolders As Object
Set oSubFolders = oFolder.Subfolders
Dim oSubfolder As Variant
For Each oSubfolder In oSubFolders
RecursiveFileSearch oSubfolder, filePattern, matchedFiles
Next
'Garbage Collection
Set oFolder = Nothing
Set oFile = Nothing
Set oSubFolders = Nothing
Set oSubfolder = Nothing
Set oFSO = Nothing
Set oRegExp = Nothing
End Sub
Perhaps:
\d{4}_\d{2}.*Monthly Report\.xlsm
My code was escaping the () and . to override the defined regex behavior. Portland Runner suggestion solved the question. ^[0-9]{3,4}[_][0-9]{2} SAMPSON International Shares Passive (Hedged) Trust Mandate Monthly Report.xlsm