Large amount of time required while replacing the words from the array. The array consist of (y[1] and y[2]) more than 25000 words. Is it possible to reduce the time?. Iam using below code for replacing.
on mouseUp
put the field SRText into myArrayToBe
split myArrayToBe by CR
put the number of lines of (the keys of myArrayToBe) into myArraylength
repeat with i = 1 to myArraylength
put myArrayToBe[i] into y
split y by colon
put y[1] into searchStr
put y[2] into replaceStr
if searchStr is empty then
put the 0 into m
else
put the htmlText of field "MytextField" into myHtml
set the caseSensitive to true
replace searchStr with "<strike><font bgcolor=" & quote & "yellow" & quote & ">" & searchStr & "</font></strike><font bgcolor=" & quote & "green" & quote & ">" & replaceStr & "</font>" in myHtml
set the htmlText of fld "MytextField" to myHtml
end if
end repeat
end mouseUp
Is there any error in this looping?
You might also consider moving the putting and setting of the htmltext outside of the repeat loop.
on mouseUp
put the htmlText of field "MytextField" into myHtml
set the caseSensitive to true
put field "SRText" into myArrayToBe
split myArrayToBe by CR
repeat for each key myKey in myArrayToBe
put myArrayToBe[myKey] into y
split y by colon
put y[1] into searchStr
put y[2] into replaceStr
if searchStr is empty then
put 0 into m
else
replace searchStr with "<strike><font bgcolor=" & quote & \
"yellow" & quote & ">" & searchStr & \
"</font></strike><font bgcolor=" & quote & "green" & quote \
& ">" & replaceStr & "</font>" in myHtml
end if
end repeat
set the htmlText of fld "MytextField" to myHtml
end mouseUp
Try repeat for each instead of repeat with. Usually, repeat for each is much quicker. It looks like arrays tend to slow down repeat for each a little. A simple list will probably be quicker.
on mouseUp
put field SRText into myArrayToBe
put the htmlText of field "MytextField" into myHtml
set the caseSensitive to true
repeat for each line myLine in myArrayToBe
set the itemDel to colon
if item 1 of myLine is empty then
put 0 into m
else
replace item 1 of myLine with "<strike><font bgcolor=" & quote & \
"yellow" & quote & ">" & item 1 of myLine & \
"</font></strike><font bgcolor=" & quote & "green" & \
quote & ">" & item 2 of myLine & "</font>" in myHtml
end if
end repeat
set the htmlText of fld "MytextField" to myHtml
end mouseUp
If the biggest problem is the blocking of the GUI, while you could accept an additional slowdown, you could also add a line wait for 0 millisecs with messages and some code to update a progress bar at the end of the repeat loop.
Related
I have pipe-delimited strings I need to find and replace on the entire substring between the pipes
So if my strings looks like
AAAP|AAA TTT|AAA|000 or AAA|AAAP|AAA TTT|AAA|000 Or AAA|AAAP|AAA TTT|AAA|AAA
The AAA can be anywhere in the string. beginning and/or end or exist multiple times
and I want to replace AAA with ZZZ
The result I need:
AAAP|AAA TTT|ZZZ|000 or ZZZ|AAAP|AAA TTT|ZZZ|000 or ZZZ|AAAP|AAA TTT|ZZZ|ZZZ
The result I am getting
AAAP|ZZZ TTT|ZZZ|000 ...
How to restrict the replacement to the entire substring
Sub ExtractSubstringReplace()
Dim strSource, strReplace, strFind, RegExpReplaceWord, r, a
strSource = "AAAP|AAA TTT|AAA|000"
strFind = "AAA"
strReplace = "ZZZ"
Dim re As Object
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.IgnoreCase = True
re.Pattern = "\b" & strFind & "\b"
RegExpReplaceWord = re.Replace(strSource, strReplace)
MsgBox RegExpReplaceWord
End Sub
You can use
re.Pattern = "(^|\|)" & strFind & "(?![^|])"
RegExpReplaceWord = re.Replace(strSource, "$1" & strReplace)
See the (^|\|)AAA(?![^|]) regex demo. Note it is equal to (^|\|)AAA(?=\||$).
Details:
(^|\|) - Capturing group 1: either start of string or a pipe char
AAA - search string
(?![^|]) / (?=\||$) - a lookahead that makes sure there is either | or end of string immediately to the right of the current location.
NOTE: if your strFind can contain special regex metacharacters, make sure you escape the string using the solution from Regular Expression and embedded special characters.
Put the string on which replacement is to be made (AAAP|AAA TTT|AAA|000) in cell A1 of Sheet1 and run the following code.
You will get the whole string with replacements made in cell A2.
Sub ExtractSubstringReplace()
Dim strArr, str, strArrNew(), strSource As String, strReplace As String, strFind As String, i As Long
strSource = Sheet1.Range("A1").Value
strFind = "AAA"
strReplace = "ZZZ"
strArr = Split(Sheet1.Range("A1").Value, "|")
For Each str In strArr
If str = strFind Then str = strReplace
ReDim Preserve strArrNew(i)
strArrNew(i) = str
i = i + 1
Next str
For Each str In strArrNew
Debug.Print str
Next str
Sheet1.Range("A2").Value = Join(strArrNew, "|")
End Sub
I would go with the option presented in the comments by #Siddharth Rout as it is probably the most efficient.
Sub Test()
MsgBox ExtractSubstringReplace("AAAP|AAA TTT|AAA|000", "AAA", "ZZZ")
MsgBox ExtractSubstringReplace("AAA|AAAP|AAA TTT|AAA|000", "AAA", "ZZZ")
MsgBox ExtractSubstringReplace("AAA|AAAP|AAA TTT|AAA|AAA", "AAA", "ZZZ")
End Sub
Public Function ExtractSubstringReplace(ByVal strSource As String _
, ByVal strFind As String _
, ByVal strReplace As String _
, Optional ByVal delimiter As String = "|" _
) As String
Dim result As String
'Duplicate delimiter and also add leading and trailing delimiter
result = delimiter & Replace(strSource, delimiter, delimiter & delimiter) & delimiter
'Replace substrings
result = Replace(result, delimiter & strFind & delimiter, delimiter & strReplace & delimiter)
'Remove leading and trailing delimiter that we added previously
result = Mid$(result, Len(delimiter) + 1, Len(result) - Len(delimiter) * 2)
'Restore delimiters
ExtractSubstringReplace = Replace(result, delimiter & delimiter, delimiter)
End Function
You can also use the function in an Excel cell.
Slightly shortened code
As addition to #ChristianBuse 's fine solution another fast approach based on the same idea (needing only 0.00 to max. 0.02 seconds):
Function SubRep(src, fnd, repl, Optional ByVal delim As String = "|") As String
SubRep = delim & src & delim
Dim i As Long
For i = 1 To 2
SubRep = Replace(SubRep, delim & fnd & delim, delim & repl & delim)
Next
SubRep = Mid$(SubRep, 2, Len(SubRep) - 2)
End Function
Example call
Sub ExampleCall()
Dim terms
terms = Array("AAAP|AAA TTT|AAA|000", "AAA|AAAP|AAA TTT|AAA|000", "AAA|AAAP|AAA TTT|AAA|AAA")
Dim i As Long
For i = LBound(terms) To UBound(terms)
Debug.Print Format(i, "0 ") & terms(i) & vbNewLine & " " & _
SubRep(terms(i), "AAA", "ZZZ")
Next
End Sub
Results in VB Editor's immediate window
0 AAAP|AAA TTT|AAA|000
AAAP|AAA TTT|ZZZ|000
1 AAA|AAAP|AAA TTT|AAA|000
ZZZ|AAAP|AAA TTT|ZZZ|000
2 AAA|AAAP|AAA TTT|AAA|AAA
ZZZ|AAAP|AAA TTT|ZZZ|ZZZ
I have a code I use to concatenate highlighted cells with a separating " OR " between them. It places the data into a text box. My problem is that it adds a final " OR " to the end of the text string. I would like the text to automatically get rid of the last " OR " or to not put it in at all.
Dim rCell As Range, strJoin As String
Dim box As TextBox
Set box = ActiveSheet.TextBoxes.Add(ActiveCell.Offset(1, 1).Left, _
ActiveCell.Offset(1, 1).Top, ActiveCell.Offset(1, 3).Left, _
ActiveCell.Offset(6, 1).Top)
With box
.Text = vbNullString
For Each rCell In Selection
strJoin = rCell
box.Text = box.Text & strJoin & " OR "
Next rCell
End With
End Sub
I have a series of these that I use to create SQL queries, and not having to manually remove the last word would be lovely.
Thank you in advance for any help you are able to provide.
I like this pattern:
Dim sep as string
For Each rCell In Selection
box.Text = box.Text & sep & rCell.Value
sep = " OR "
Next rCell
As the title says, I am unable to pass a String parameter through an OnAction that occurs when a checkbox is checked. I have successfully passed two integer values to the sub when the checkbox is checked, but now I need to also pass a String parameter (the String is actually the name of the current Worksheet).
This is currently what it looks like:
'Start of for loop which will run from the lower bound of esq to the upper bound.
For i = LBound(esq) To UBound(esq)
'Inserts a row at the specified location, the current row + 1 + the value of i (0 to 12 depending on which run of the loop it is currently on).
workSource.Rows(rowPos + 1 + i).Insert
'Sets cb as equal to the specified cell in the newly inserted row.
Set cb = workSource.CheckBoxes.Add(Cells(rowPos + 1 + i, colPos + 1).Left, Cells(rowPos + 1 + i, colPos + 1).Top, _
Cells(rowPos + 1 + i, colPos + 1).Width, Cells(rowPos + 1 + i, colPos + 1).Height)
'Start of With which sets the attributes of cb.
With cb
'Sets the caption as the current element of esq.
.Caption = esq(i)
'Links the checkbox with the cell directly beneath it.
.LinkedCell = Cells(rowPos + 1 + i, colPos + 1).Address
'Adds a macro which will be activated when it is clicked. The cell's row and column position will be passed as parameters to the macro.
.OnAction = "'ProcessCheckBox " & rowPos + 1 & "," & colPos + 1 + i & "," & currentName & "'"
'.OnAction = "'" & ThisWorkSheet.Name & "'!ProcessCheckBox"
'.OnAction = "'ProcessCheckBox " & rowPos + 1 & "," & colPos + 1 + i & "," & """SES""" & "'"
'.OnAction = "'ProcessCheckBox " & currentName & "'"
'End of With.
End With
'Starts next run of loop and increments i.
Next i
There are three commented out lines of OnAction that I attempted to experiment with in order to get just the string to be passed. Unfortunately, none of them worked. Here is the start of the code for the ProcessCheckBox sub:
'Sub to process when a checkbox has been changed.
Sub ProcessCheckBox(ByVal rowPos As Integer, ByVal colPos As Integer, ByVal currentSheet As String)
'Sub ProcessCheckBox(ByVal currentSheet As String)
MsgBox currentSheet
'Declares a worksheet object named currentSheet.
Dim activeSheet As Worksheet
'Sets currentSheet equal to the active worksheet.
Set activeSheet = ThisWorkbook.Worksheets(currentSheet)
'Set currentSheet = ActiveSheet
After clicking the checkbox, a msgbox appears that is completely blank, and then I run into an error where it says the subscript is out of range.
I gather from this that the sub is being called, the String value is just not being passed along. The string value in the first sub (currentName) does have a value, as I can print it out and use it for calculations just fine.
I think the problem is in the OnAction line itself. It took me a while to figure out how to pass the integer values due to not knowing the correct number of single and double quotes to use. I think it has to do with this, however, all of the other examples I saw passed String values like this. I even experimented by adding or removing quotes just to see if it would work out and nothing.
Other errors I thought it might be: a sub has a limit to how many/large parameters can be passed to it, only parameters of a single type can be passed (either String or Integer). Neither of these make sense because I have encountered many examples that pass much more data across many different types to a sub.
Thank you to the people who answered, but neither of the solutions offered worked. I've been testing the macro and it appears no matter what I do, it will not pass a string as a parameter, either alone or with other parameters. I don't know why.
Here are the two lines in question I have narrowed it down to :
.OnAction = "'ProcessCheckBox " & colPos + 1 & "," & rowPos + 1 + i & ",""" & nameSheet & """'"
And the first line of the sub :
Sub ProcessCheckBox(ByVal colPos As Integer, ByVal rowPos As Integer, ByVal sheetName As String)
Ticking the checkbox gives me an error saying "Argument Not Optional." However, it doesn't allow me to go into debug mode, and it doesn't highlight the specific line either, although I have tested it and believe these two lines to be the problem.
I've given up on figuring VBA's single and double quotes and acknowledge that I never needed anything to be passed as argument that wasn't available in the workbook in which the check box resides. Therefore I can easily get all the information I might want to pass directly from the worksheet.
Where that may not be enough, I also get access to the CheckBox object itself. All my needs for arguments can be satisfied completely without any quotation marks.
Private Sub CheckBox1_Click()
Dim ChkBox As Shape
Set ChkBox = ActiveSheet.Shapes(Application.Caller)
MsgBox ChkBox.Parent.Name & vbcr & _
ChkBox.OLEFormat.Object.Name
End Sub
Here are 3 possible solutions for your problem, all involving the Application.Caller.
Please run this code on your project.
Sub CheckBox1_Click()
Dim ChkBox As Shape
Dim WsName As String, Rpos As Long, Cpos As Long
Dim Cell As Range
' Solution 1
WsName = ActiveSheet.Shapes(Application.Caller).OLEFormat.Object.Parent.Name
MsgBox "You already know how to pass the cell coordinates" & vbCr & _
"Just get the Sheet name from here:" & vbCr & _
"Sheet name is """ & WsName & """"
Set ChkBox = ActiveSheet.Shapes(Application.Caller)
' Solution 2
Set Cell = ChkBox.OLEFormat.Object.TopLeftCell
Rpos = Cell.Row
Cpos = Cell.Column
WsName = Cell.Worksheet.Name
MsgBox "Solution 2" & vbCr & _
"The checkbox Top Left is aligned with the" & vbCr & _
"Linked Cell's Top Left:-" & vbCr & _
"Row number = " & Rpos & vbCr & _
"Column number = " & Cpos & vbCr & _
"Worksheet name = " & WsName & vbCr & _
"If Alignment of underlying cell and TopLeft" & vbCr & _
"isn't perfect, modify the placement in your other code." & vbCr & _
"Here is the TopLeft address:-" & vbCr & _
"TopLeftCell address = " & Cell.Address
' Solution 3
Set Cell = Range(ChkBox.OLEFormat.Object.LinkedCell)
Rpos = Cell.Row
Cpos = Cell.Column
WsName = Cell.Worksheet.Name
MsgBox "Solution 3" & vbCr & _
"Get the information directly from the Linked Cell." & vbCr & _
"(This is probably the one you are interested in):-" & vbCr & _
"Row number = " & Rpos & vbCr & _
"Column number = " & Cpos & vbCr & _
"Worksheet name = " & WsName & vbCr & _
"This method might fail if the linked cell" & vbCr & _
"is altered, perhaps manually."
End Sub
First off, I know there's a million questions about formatting dates, but I have not found a solution that works with my situation.
We are given a .csv file, and due to requirements, we must modify the file in a couple of ways.
Firstly, we run a VBA on the file in order to change the delimiter from "," to "|" (we have this working) using:
Const ForReading = 1
Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("C:\Users\Z00393885\Desktop\csvStuff\"&myVar, ForReading)
count = 0
Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
strReplacer = Chr(34) & "," & Chr(34)
strLine = Replace(strLine, strReplacer, "|")
strLine = Replace(strLine, chr(34), "")
strNewText = strNewText & strLine & vbCrLF
count = count + 1
Loop
Print (count - 1)
objFile.Close
Set objFile = objFSO.OpenTextFile("C:\Users\Z00393885\Desktop\csvStuff\"&myVar, ForWriting)
objFile.WriteLine "BOF" & vbCrLF & now() & vbCrLF & (count - 1) & vbCrLF & strNewText & "EOF"
objFile.Close
The second requirement is the one that's giving me trouble, I have to look for every Date that is present (they are formatted: 11/8/2017 1:30 EST and lie within the 10th and 11th columns) and format the date so that it would be 11/08/2017 (we need to remove the Time as well as make sure that the day and month has a 0 if its only a single digit)
Is this doable within the Do Until loop? or would it be better to have a separate function to take care of that part. Either way, I am not even sure where to start with manipulating Dates within a file like this and not just a variable
EDIT: here is some of the .csv file
BOF
11/1/2017 12:08:21 PM
3
Course Code|Home Org|...|Release Date|Effective Date|...|Web Address
123|TAD Sites|...|10/31/2017 00:00:00 EDT|11/14/2017 00:00:00 EDT|...|http://URL
456|DAT Sites|...|11/5/2017 00:00:00 EDT|11/5/2017 00:00:00 EDT|...|http://URL
EOF
One thing you could do is split the original line into the columns, then you only need to consider the 10th and 11th columns:
Dim myArray() As String
'...
strLine = objFile.ReadLine
'Current delimiter is quote-comma-quote
strReplacer = Chr(34) & "," & Chr(34)
'Replace current delimiter with a pipe delimiter
strLine = Replace(strLine, strReplacer, "|")
'Remove any remaining quote marks
strLine = Replace(strLine, Chr(34), "")
'Split line using pipe delimiter
myArray = Split(strLine, "|")
'Convert column 10
myArray(9) = Format(CDate(Left(myArray(9), InStr(myArray(9), " ") - 1)), "mm/dd/yyyy")
'Convert column 11
myArray(10) = Format(CDate(Left(myArray(10), InStr(myArray(10), " ") - 1)), "mm/dd/yyyy")
'Join line back together with pipe delimiter
strLine = Join(myArray, "|")
'Create one huge string containing all lines in file
strNewText = strNewText & strLine & vbCrLF
'...
To use this as VBScript will require a few minor changes:
'Dim myArray() As String
Dim myArray
'...
strLine = objFile.ReadLine
'Current delimiter is quote-comma-quote
strReplacer = Chr(34) & "," & Chr(34)
'Replace current delimiter with a pipe delimiter
strLine = Replace(strLine, strReplacer, "|")
'Remove any remaining quote marks
strLine = Replace(strLine, Chr(34), "")
'Split line using pipe delimiter
myArray = Split(strLine, "|")
'Convert column 10
'myArray(9) = Format(CDate(Left(myArray(9), InStr(myArray(9), " ") - 1)), "mm/dd/yyyy")
myArray(9) = FormatDateTime(CDate(Left(myArray(9), InStr(myArray(9), " ") - 1)), 0)
'Convert column 11
'myArray(10) = Format(CDate(Left(myArray(10), InStr(myArray(10), " ") - 1)), "mm/dd/yyyy")
myArray(10) = FormatDateTime(CDate(Left(myArray(10), InStr(myArray(10), " ") - 1)), 0)
'Join line back together with pipe delimiter
strLine = Join(myArray, "|")
'Create one huge string containing all lines in file
strNewText = strNewText & strLine & vbCrLF
'...
I don't use VBScript myself, but I believe the FormatDateTime function will give you what you want as output. It seems to be locale-specific, but I assume you use mm/dd/yyyy format as standard in your location.
Have you thought about running a "text to column" function, simply altering the formats to the date columns, then outputting the file? This might be a lot easier than searching for characters and altering them the way you are doing.
With Range(pass the range here)
.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(..., ...),_
TrailingMinusNumbers:=True
Columns("x:x").NumberFormat = "mm/dd/yyyy"
From here you can save the file.
EDIT:
One caveat: you need to hard code the number of columns you will end up with into the array.
For example, if each row of the file contains 4 sections, you would use:
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True
This is what I am trying to do:
If J contains the word Defendant
And
If F contains the word Foreclosure
Then
If G contains " V ESTATE OF "
Then keep everything to the right of "OF"
Else If G contains " VS "
Then keep everything to the right of " VS "
Else If G contains " V " (notice the spaces before and after V)
Then keep everything to the right of " V "
If K contains " " (two consecutive spaces)
Then Keep it
Or
If K contains "UNKNOWN SPOUSE OF"
Then remove the very last character of cell, which will be a comma
And if the cell begins with an underscore
Then remove it
Then Keep it
Assign the result of G to the corresponding N cell
Assign the result of K to the corresponding O cell
This is what I did:
Sub Inspect()
Dim RENums As Object
Dim RENums2 As Object
Dim LValue As String
Dim LValue2 As String
Set RENums = CreateObject("VBScript.RegExp")
Set RENums2 = CreateObject("VBScript.RegExp")
RENums.Pattern = "DEFENDANT"
RENums2.Pattern = "FORECLOSURE"
Dim lngLastRow As Long
lngLastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Dim i
For i = 1 To lngLastRow
If RENums2.test(Range("F" & i).Value) Then
If RENums.test(Range("J" & i).Value) Then
pos = InStr(Range("G" & i), " V ")
pos2 = InStr(Range("G" & i), " VS ")
pos3 = InStr(Range("G" & i), " V ESTATE OF ")
dbspace = InStr(Range("K" & i), " ")
If pos3 <> 0 Then
LValue2 = Right(Range("G" & i), Len(Range("G" & i)) - pos * 2)
ElseIf pos <> 0 Then
LValue2 = Right(Range("G" & i), Len(Range("G" & i)) - pos - 2)
ElseIf pos2 <> 0 Then
LValue2 = Right(Range("G" & i), Len(Range("G" & i)) - pos - 2)
End If
If dbspace <> 0 Then
LValue = Range("K" & i)
End If
schr = Right(LValue, 1)
If schr = "_" Then
With WorksheetFunction
Range("N" & i).Value = Trim(.Substitute(LValue, "_", ""))
End With
Else
Range("N" & i).Value = Trim(LValue)
End If
Range("O" & i).Value = Trim(LValue2)
End If
End If
Next i
End Sub
With the above macro, the correct value is never pasted into N in some cases. Rather a value from another cell in K is pasted to the wrong cell in N.
I attached an example of excel spreadsheet on the below link to which I never received a response:
http://www.excelforum.com/excel-programming/775695-wrong-data-copied-into-new-cell-from-macro.html
Thanks for response.
Your LValue and LValue2 variables are being populated conditionally (ie, not each time through the loop), but your final block is executed EVERY TIME, so it stands to reason that some times through the loop, you are using an old value of LValue or LValue2 (or both).
You need to clear them out at the beginning of the loop, or else have an ELSE clause in both your LValue and LValue2 IF blocks that takes care of that scenario.
Edit based on your comment: I prefer using MID() to RIGHT() in this scenario, makes it much easier to get the math right, since we're counting from the left (which is the value that InStr() returns):
cellText = Range("K" & i).Value
LValue = Mid(cellText, Unknown + 18, 100)
A few additional notes:
You use it so many times, put the tested value into a variable like I did above. It might even be marginally faster that way instead of going back to the worksheet each time.
I prefer to use Cells(11, i).Value to Range("K" & i).Value. Works the same, but much easier to use with variable row or column numbers.
It usually works the way you've done it, but make sure to use the correct property of the range object (Range().Value or Range().Formula or whatever) instead of just relying on the "default property" to always be correct.
When checking for the underscore, you are testing if the last character is an underscore. Your question states that you want to test if the value begins with an underscore.
schr = Right(LValue, 1)
If schr = "_" Then
Try
schr = Left(LValue, 1)
If schr = "_" Then