I'm trying to modify a parsing script to exclude a record in the first field that does not have a value but I want the script to finish the file.
lastRO = ""
FirstLine = True
FacilityCode = Left(InputFile, InStr(InputFile,"_")-1)
Do Until EOF
a = CSVParser(ExtractLine(0))
If a(1) <> lastRO Then
If FirstLine Then
FirstLine = False
Else
WriteFields()
End If
lastRO = a(1)
Field("Department") = ""
Field("RepairOrder") = FacilityCode & a(1)
End If
Dim xReg
Set xReg = new RegExp
For i = 0 to Ubound(RepairOrderDepartmentExpressions)
xReg.Pattern = RepairOrderDepartmentExpressions(i)
If xReg.Test(a(RepairOrderDepartmentField(i))) Then
If Field("Department") = "" Or Field("Department") = RepairOrderDepartmentKey(i) Then
Field("Department") = RepairOrderDepartmentKey(i)
Else
Field("Department") = RepairOrderSharedDepartment
End if
Exit For
End if
Next
Skip
Loop
Related
I need to write a MS Word macro to count occurence of every word within a given document and print out the list like .
I did the macro and it works, but it is so sloooow, it takes several hours to get results for a document of 60000 words.
Could you please give me some advices/suggestions on how to make the macro run faster?
(I checked a similar question here WORD VBA Count Word Occurrences but still don't get it how to speed up and need my macro to be reviewed). Thank you.
Private Type WordStatData
WordText As String
WordCount As Integer
End Type
Option Base 1
'Check if the word is valid
Private Function IsValidWord(SomeString As String) As Boolean
Dim Retval As Boolean
Retval = True
If Not (InStr(SomeString, " ") = 0) Then Retval = False
If Not (InStr(SomeString, ".") = 0) Then Retval = False
If Not (InStr(SomeString, ",") = 0) Then Retval = False
If Not InStr(SomeString, "0") = 0 Then Retval = False
If Not InStr(SomeString, "1") = 0 Then Retval = False
If Not InStr(SomeString, "2") = 0 Then Retval = False
If Not InStr(SomeString, "3") = 0 Then Retval = False
If Not InStr(SomeString, "4") = 0 Then Retval = False
If Not InStr(SomeString, "5") = 0 Then Retval = False
If Not InStr(SomeString, "6") = 0 Then Retval = False
If Not InStr(SomeString, "7") = 0 Then Retval = False
If Not InStr(SomeString, "8") = 0 Then Retval = False
If Not InStr(SomeString, "9") = 0 Then Retval = False
IsValidWord = Retval
End Function
Private Sub CommandButton1_Click()
SpanishLCID = 3082 'The source text is in Spanish
ListBox1.Clear
Dim WordsTotal As Long
WordsTotal = ActiveDocument.Words.Count
TextBox1.Text = Str(WordsTotal)
Dim Wordfound As Boolean
Dim NewWord As String
Dim MyData() As WordStatData
ReDim Preserve MyData(1)
NewWord = ""
For i = 1 To WordsTotal
NewWord = Trim(StrConv(Trim(ActiveDocument.Words(i)), vbLowerCase, SpanishLCID))
'Check if the word is in the list
If IsValidWord(NewWord) Then
Wordfound = False
For j = 1 To UBound(MyData)
If StrComp(MyData(j).WordText, NewWord) = 0 Then
Wordfound = True: Exit For
End If
Next j
If Wordfound Then
MyData(j).WordCount = MyData(j).WordCount + 1
Else
ReDim Preserve MyData(UBound(MyData) + 1)
MyData(UBound(MyData)).WordText = NewWord
MyData(UBound(MyData)).WordCount = 1
End If
End If
Next i
'Printing out the word list
For i = 1 To UBound(MyData)
ListBox1.AddItem (MyData(i).WordText & "=" & Str(MyData(i).WordCount))
Next i
End Sub
Add a reference to the Microsoft Scripting Runtime (Tools -> References...). Then use the following:
Private Sub CommandButton1_Click()
Const SpanishLCID = 3082
Dim dict As New Scripting.Dictionary, word As Variant, fixedWord As String
Dim key As Variant
dict.CompareMode = SpanishLCID
For Each word In ActiveDocument.Words
fixedWord = Trim(StrConv(Trim(word), vbLowerCase, SpanishLCID))
If Not dict.Exists(fixedWord) Then
dict(fixedWord) = 1
Else
dict(fixedWord) = dict(fixedWord) + 1
End If
Next
ListBox1.Clear
For Each key In dict.Keys
ListBox1.AddItem key & "=" & dict(key)
Next
End Sub
NB. Word treats each punctuation symbol or paragraph as a new word. It may be advisable to specify another Dictionary or Collection with the strings that shouldn't be added to the dictionary, and test for those strings using .Exists before adding to the dictionary.
A more concise version of IsValidWord without regular expressions:
Function IsValidWord(s As String) As Boolean
Const validChars As String = "abcdefghijklmnopqrstuvwxyz"
Dim i As Integer, char As String * 1
For i = 1 To Len(s)
char = Mid(s, i, 1)
If InStr(1, validChars, char, vbTextCompare) = 0 Then Exit Function
Next
IsValidWord = True
End Function
and using regular expressions (add a reference to Microsoft VBScript Regular Expressions 5.5):
Dim regex As RegExp
Function IsValidWord2(s As String) As Boolean
If regex Is Nothing Then
Set regex = New RegExp
regex.Pattern = "[^a-z]"
regex.IgnoreCase = True
End If
IsValidWord2 = Not regex.Test(s)
End Function
and using regular expressions with replacement:
Function GetValidWord(s As String) As String
'GetValidWord("Introduction.......3") will return "Introduction"
If regex2 Is Nothing Then
Set regex2 = New RegExp
regex2.Pattern = "[^a-z]"
regex2.Global = True
regex2.IgnoreCase = True
End If
GetValidWord = regex2.Replace(s, "")
End Function
and you would use it as follows:
For Each word In ActiveDocument.Words
fixedWord = Trim(StrConv(Trim(word), vbLowerCase, SpanishLCID))
fixedWord = GetValidWord(fixedWord)
If Not dict.Exists(fixedWord) Then
NB: You might combine the language conversion and Trim into GetValidWord.
How to find the first instance of a "lower case character" in a cell using VBA in Excel?
I have tried using ASCII values but that didn't work.
Try the following small UDF:
Public Function Findlower(rin As Range) As Long
Dim v As String, CH As String, i As Long
Findlower = 0
v = rin.Text
L = Len(v)
For i = 1 To L
If Mid(v, i, 1) Like "[a-z]" Then
Findlower = i
Exit Function
End If
Next i
End Function
It will return the position of the first instance of any lower case letter in a string:
You can use a RegExp in a UDF to avoid looping through each character:
Function FirstLower(strIn As String) as String
Dim objRegex As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "[a-z]"
.ignorecase = False
If .test(strIn) Then
Set objRegM = .Execute(strIn)(0)
FirstLower = objRegM.firstindex + 1
Else
FirstLower = "no match"
End If
End With
End Function
I think you want to remove the first part in your string that is in lower case:
Public Function DeletFirstLowerPart(strTemp As String) As String
Dim strResult As String, i As Long, findLower As Boolean
strResult = ""
findLower = False
For i = 1 To Len(strTemp)
If (Mid(strTemp, i, 1) Like "[a-z]") Then
findLower = True
Else
If findLower = True Then
strResult = strResult & Mid(strTemp, i)
DeletFirstLowerPart = strResult
Exit Function
End If
strResult = strResult & Mid(strTemp, i, 1)
End If
Next i
DeletFirstLowerPart = strResult
End Function
DeletFirstLowerPart("ABCdefGHI") = "ABCGHI"
DeletFirstLowerPart("ABCdefGHIjkl") = "ABCGHIjkl"
Private Function DeleteLowerCasesLike(InputString As String) As String
Dim i As Integer
For i = 1 To Len(InputString)
If Mid(InputString, i, 1) Like "[a-z]" Then
InputString = Left(InputString, i - 1) & Mid(InputString, i + 1)
i = i - 1
End If
Next
DeleteLowerCasesLike = InputString
End Function
Another RegExp solution which needs to addig referance to Microsoft VBScript Regular Expressions 1.0 (In the VBA window, Tools->Referances menu)
Private Function DeleteLowerCasesRegExp(InputString As String)
Dim RE As New RegExp
With RE
.Global = True
.IgnoreCase = False
.Pattern = "[a-z]"
DeleteLowerCasesRegExp = .Replace(InputString, "")
End With
End Function
And another solution nor Like neither RegExp is used:
Private Function DeleteLowerCasesAsc(InputString As String) As String
Dim i As Integer
For i = 1 To Len(InputString)
If Mid(InputString, i, 1) = Empty Then Exit For
If Asc(Mid(InputString, i, 1)) >= 97 And Asc(Mid(InputString, i, 1)) <= 122 Then
InputString = Left(InputString, i - 1) & Mid(InputString, i + 1)
i = i - 1
End If
Next
DeleteLowerCasesAsc = InputString
End Function
Another solution in which replace function is used:
Private Function DeleteLowerCasesReplace(InputString As String) As String
Dim i As Integer
For i = 97 To 122
InputString = Replace(InputString, Chr(i), "")
Next
DeleteLowerCasesReplace = InputString
End Function
my problem today is a part of a subroutine that inexplicably breaks its execution when a Workbook is closed.
I have written the following code:
Public Const Pi As Double = 3.14159265358979
Public Const Rad As Double = Pi / 180
Public CalcBook As Workbook
Public FilePath As String, Files() As String
Public FreqArray() As Integer
Sub Main()
Dim ChooseFolder As Object, FilePath As String, StrFile As String
Dim i As Integer, j As Integer, k As Integer, x As Integer
Dim DirNum As Integer, HNum As Integer, VNum As Integer
Dim DirColShift As Integer, HColShift As Integer, VColShift As Integer
Dim TheStart As Date, TheEnd As Date, TotalTime As Date
Set ChooseFolder = Application.FileDialog(msoFileDialogFolderPicker)
With ChooseFolder
.AllowMultiSelect = False
.Title = "Please choose a folder containing .txt files"
If .Show = -1 Then
FilePath = .SelectedItems(1) & "\"
Else
Set ChooseFolder = Nothing
Exit Sub
End If
End With
Set ChooseFolder = Nothing
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
' Stores only files containing an AntennaName + "_T" + any number of characters + "_?_?45.xls" string
' (where "?" is a single character and "*" is any number). Checks if the number of files is correct too.
StrFile = Dir(FilePath & "*_T*_?_?45.txt")
Do While Len(StrFile) > 0
ReDim Preserve Files(i)
Files(i) = FilePath & StrFile
i = i + 1
StrFile = Dir
Loop
If Not (UBound(Files) + 1) / 6 = Int((UBound(Files) + 1) / 6) Then GoTo FileError
For i = 0 To UBound(Files)
Select Case Right(Files(i), 9)
Case "D_+45.txt", "D_-45.txt"
DirNum = DirNum + 1
Case "H_+45.txt", "H_-45.txt"
HNum = HNum + 1
Case "V_+45.txt", "V_-45.txt"
VNum = VNum + 1
End Select
Next
If Not (DirNum / 2 = Int(DirNum / 2) And HNum / 2 = Int(HNum / 2) And VNum / 2 = Int(VNum / 2) And DirNum = HNum And HNum = VNum) Then
FileError:
MsgBox "Failed to properly load files. Looks like a wrong number of them is at dispose", vbCritical, "Check the import-files"
Exit Sub
End If
' Imports files in Excel for better data access
Set CalcBook = Application.Workbooks.Add
' FROM HERE ON THE DATA IS PROCESSED IN ORDER TO OBTAIN AN EXCEL WORKBOOK WITH 3 SHEETS CALLED "Directivity", "Horizontal" and "Vertical".
Application.ScreenUpdating = True
Options.Show
TheStart = Now
Application.ScreenUpdating = False
If Options.OnlyEval = False Then PolarCharts
If Options.OnlyCharts = False Then Auswertung
Application.DisplayAlerts = False
CalcBook.Close savechanges:=False
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Set CalcBook = Nothing
TheEnd = Now
TotalTime = TheEnd - TheStart
MsgBox Format(TotalTime, "HH:MM:SS"), vbInformation, "Computing Time"
Unload Options
End Sub
Options is a form which I need in order to access data for the PolarCharts and Auswertung. These Subs are correctly executed (I know that because the data they save is correct too).
I tried deleting the .ScreenUpdating and .DisplayAlerts commands, as well as the Unload thinking that they could bugging something, but the result hasn't changed.
Know also that the Workbook I'm closing contains NO CODE at all (and nothing else addresses a ".Close" so it's impossible that something is executed on the .Close event).
Below my "Options" code:
Private Sub Cancel_Click()
End
End Sub
Private Sub UserForm_Terminate()
End
End Sub
Private Sub Ok_Click()
If Me.OnlyCharts = False Then
ReDim SubFreq(4)
If Not (Me.Start1.ListIndex = -1 And Me.Stop1.ListIndex = -1) Then SubFreq(0) = Me.Start1.List(Me.Start1.ListIndex) & "-" & Me.Stop1.List(Me.Stop1.ListIndex)
If Not (Me.Start2.ListIndex = -1 And Me.Stop2.ListIndex = -1) Then SubFreq(1) = Me.Start2.List(Me.Start2.ListIndex) & "-" & Me.Stop2.List(Me.Stop2.ListIndex)
If Not (Me.Start3.ListIndex = -1 And Me.Stop3.ListIndex = -1) Then SubFreq(2) = Me.Start3.List(Me.Start3.ListIndex) & "-" & Me.Stop3.List(Me.Stop3.ListIndex)
If Not (Me.Start4.ListIndex = -1 And Me.Stop4.ListIndex = -1) Then SubFreq(3) = Me.Start4.List(Me.Start4.ListIndex) & "-" & Me.Stop4.List(Me.Stop4.ListIndex)
If Not (Me.Start5.ListIndex = -1 And Me.Stop5.ListIndex = -1) Then SubFreq(4) = Me.Start5.List(Me.Start5.ListIndex) & "-" & Me.Stop5.List(Me.Stop5.ListIndex)
If (Me.Start1 = "" And Me.Start2 = "" And Me.Start3 = "" And Me.Start4 = "" And Me.Start5 = "" And Me.Stop1 = "" And Me.Stop2 = "" And Me.Stop3 = "" And Me.Stop4 = "" And Me.Stop5 = "") _
Or Me.Start1.Value > Me.Stop1.Value Or Me.Start2.Value > Me.Stop2.Value Or Me.Start3.Value > Me.Stop3.Value Or Me.Start4.Value > Me.Stop4.Value Or Me.Start5.Value > Me.Stop5.Value _
Or (Me.Start1.ListIndex = -1 And Me.Stop1.ListIndex >= 0) Or (Me.Start2.ListIndex = -1 And Me.Stop2.ListIndex >= 0) Or (Me.Start3.ListIndex = -1 And Me.Stop3.ListIndex >= 0) Or (Me.Start4.ListIndex = -1 And Me.Stop4.ListIndex >= 0) Or (Me.Start5.ListIndex = -1 And Me.Stop5.ListIndex >= 0) _
Or (Me.Start1.ListIndex >= 0 And Me.Stop1.ListIndex = -1) Or (Me.Start2.ListIndex >= 0 And Me.Stop2.ListIndex = -1) Or (Me.Start3.ListIndex >= 0 And Me.Stop3.ListIndex = -1) Or (Me.Start4.ListIndex >= 0 And Me.Stop4.ListIndex = -1) Or (Me.Start5.ListIndex >= 0 And Me.Stop5.ListIndex = -1) Then
MsgBox("Please select correctly the frequency ranges - Maybe Start > Stop, one of those was not properly inserted, or the fields are blank", vbExclamation, "Frequency choice error")
GoTo hell
End If
For i = 0 To 4
If Not SubFreq(i) = "" Then j = j + 1
Next i
j = j - 1
ReDim Preserve SubFreq(j)
End If
Me.Hide
hell:
End Sub
Private Sub UserForm_Initialize()
Dim i As Byte
Me.StartMeas = Date
Me.StopMeas = Date
Me.Worker.AddItem "lol"
Me.Worker.AddItem "rofl"
Me.Worker.ListIndex = 0
For i = LBound(FreqArray) To UBound(FreqArray)
Me.Start1.AddItem FreqArray(i)
Me.Start2.AddItem FreqArray(i)
Me.Start3.AddItem FreqArray(i)
Me.Start4.AddItem FreqArray(i)
Me.Start5.AddItem FreqArray(i)
Me.Stop1.AddItem FreqArray(i)
Me.Stop2.AddItem FreqArray(i)
Me.Stop3.AddItem FreqArray(i)
Me.Stop4.AddItem FreqArray(i)
Me.Stop5.AddItem FreqArray(i)
Next i
Me.Start1.ListIndex = 0
Me.Stop1.ListIndex = Me.Stop1.ListCount - 1
End Sub
Apparently when I Close CalcBook, it triggers the UserForm_Terminate event from Options which Ends all the code! How do I avoid this?
Just remove the statement End bacause End causes the abrupt end of code execution.
I see End in the Cancel and Terminate event handlers. If you have it on other places, remove it es well.
If you need exit from a method then use Exit Sub.
Why: because End work that way. Read e.g. this post: http://www.vbforums.com/showthread.php?511766-Classic-VB-Why-is-using-the-End-statement-(or-VB-s-quot-stop-quot-button)-a-bad-idea.
If you need stop code from execution use If-condition or even Exit Sub but avoid using End for it.
Try
Workbooks("CalcBook").Close savechanges:=False
I suspect that both error alerts and indications of an error on the screen are being suppressed
I am new at vbs and am getting a error at the line set arr = readfile( FileName )
I am trying to read an file into an array
and can not figure out what i am doing wrong
Thanks in advance for your assistance
Dim FileName ' File Name to Process
Call MainProcedure
WScript.Quit
Sub MainProcedure
filename = "c:\print\check.bat"
WScript.Echo( "Printing document in progress..." )
WScript.Echo( "Filename ====> " & FileName )
Dim arr, i
i = 0
set arr = readfile( FileName )
For Each present In arr
' user = split(present,",")
' WScript.Echo user(0) & user(1) & user(2) & user(3) & user(4) & "|"
i = i + 1
WScript.Echo present & "|"
Next
End Sub
Sub readfile(strFile)
dim fs,objTextFile
set fs=CreateObject("Scripting.FileSystemObject")
If (fs.FileExists( strFile)) Then
dim userArrayList
set objTextFile = fs.OpenTextFile(strFile)
Set userArrayList = CreateObject( "System.Collections.ArrayList" )
Do Until objTextFile.AtEndOfStream
strNextLine = objTextFile.Readline
userArrayList.add strNextLine
Loop
objTextFile.Close
set objTextFile = Nothing
set fs = Nothing
set readfile = userArrayList
Else
'Alert User
WScript.Echo("File does not exist!")
WScript.Quit()
End If
end Sub
Your
set arr = readfile( FileName )
implies that readfile() is a Function (returning an ArrayList). But you define
Sub readfile(strFile)
...
set readfile = userArrayList
...
end Sub
You may try to change this to
Function readfile(strFile)
...
set readfile = userArrayList
...
End Function
ADDED:
The task "Read a files' lines into an array" can be done in a much more simple way:
cscript fitoar.vbs
0 Option Explicit
1 Dim a : a = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile("fitoar.vbs").ReadAll(), vbCrLf)
2 Dim l
3 For l = 0 To UBound(a)
4 WScript.Echo l, a(l)
5 Next
6
I need to count the number of #define lines in C files (3 of them) using VBS. Please suggest the best way to accomplish this.
The script below uses a regular expression to count the #define statements that appear at the beginning of the lines. Whitespace is allowed before the statement as well as between # and define. The list of files to search in should be passed in as arguments, e.g.:
cscript.exe script_name.vbs c:\myfile1.c c:\myfile2.c
Here's the script code:
Const ForReading = 1
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set re = New RegExp
re.Pattern = "^\s*#\s*define\b"
re.IgnoreCase = False
re.Global = True
re.Multiline = True
strReport = ""
For Each strFileName in WScript.Arguments.Unnamed
Set oFile = oFSO.OpenTextFile(strFileName, ForReading)
strText = oFile.ReadAll
oFile.Close
intCount = re.Execute(strText).Count
strReport = strReport & "There are " & intCount & " #define statement(s) in " & strFileName & vbNewLine
Next
WScript.Echo strReport
The script output is like:
There are 7 #define statement(s) in c:\myfile1.c
There are 0 #define statement(s) in c:\myfile2.c
How about something like this? just pass the files in as arguments
Const token = "#define"
Set objArgs = WScript.Arguments
tokenCount = 0
Set fso = CreateObject("Scripting.FileSystemObject")
For i = 0 To objArgs.Count - 1
Set objFile = fso.OpenTextFile(objArgs(i), 1)
Do Until objFile.AtEndofStream
lineCount = lineCount + 1
If InStr(1, objFile.ReadLine, token, 1) 0 Then
tokenCount = tokenCount + 1
End If
Loop
Next
WScript.echo tokenCount
This will ignore blank spaces between # and define
Const token = "#define"
Set objArgs = WScript.Arguments
tokenCount = 0
Set fso = CreateObject("Scripting.FileSystemObject")
For i = 0 To objArgs.Count - 1
Set objFile = fso.OpenTextFile(objArgs(i), 1)
Do Until objFile.AtEndofStream
lineCount = lineCount + 1
If InStr(1, Replace(objFile.ReadLine, " ", "", 1, -1, 1), token, 1) 0 Then
tokenCount = tokenCount + 1
End If
Loop
Next
WScript.echo tokenCount
This code should count all #define statements in any number of input files. Provisions have been made for whitespace in the statements, such as "# define" or "# define" both of which are valid statements.
NOTE: I do not count for the # on one line and the "define" on the next, I'm assuming the # and "define" are at least on the same line, though you could do so by reading the entire file and removing all whitespace, then save to a variable or temp file or something like that and use that as your input.
You can shorten the code a bunch by ditching the file access constants and what not, otherwise it will give you output like this:
There are: 9 define statements in the source: c:\define.txt
There are: 11 define statements in the source: c:\define2.txt
There are: 10 define statements in the source: c:\define3.txt
The command line would be: cscript scriptname.vbs c:\define.txt c:\define3.txt etc...
' Define constants for file access
Const TristateFalse = 0
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objArgs = WScript.Arguments
If objArgs.Count > 0 then
For i = 0 To objArgs.Count - 1
Set objFileInputStream = objFSO.OpenTextFile(objArgs(i), ForReading, False, TristateFalse)
intTempCount = 0
tokenCount = 0
Do while not objFileInputStream.AtEndOfStream
strLine = replace(ucase(objFileInputStream.ReadLine), " ", "")
intLineLength = len(strLine)
Do
If instr(strLine, "#DEFINE") <> 0 then
tokenCount = tokenCount + 1
strLine = replace(strLine, "#DEFINE","", 1, 1)
intTempCount = intTempCount + 1
else
exit do
End If
Loop until intTempCount = intLineLength
Loop
objFileInputStream.Close
wscript.echo "There are: " & tokenCount & " define statements in the source: " & objArgs(i)
Next
Else
wscript.echo "You must enter at least one filename."
End If
I'm not that good at VB script, but something like ...
Dim re as New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "#define"
Set mc = re.Execute(yourFileText)
ans = mc.Count