I am performing a keyword search (looping through an Excel column, looking for keywords contained in another spreadsheet, and assigning values to another column in the first spreadsheet if they are found). I'm doing this by making use of for loops and if - else statements, and it's proving to be rather slow. The keywords sheet has three columns in which you can enter keywords, and one column used to assign a value. The idea is that the text being scanned should contain all keywords entered in these keyword columns if the value is to be assigned. Placing a "-" before the keyword means that the value should only be assigned if the scanned text does not contain the keyword indicated. See the code below for the method used. The focus of my question in the efficiency of it.
Dim intLoopKeywordsRows As Integer
Dim intLoopDataShortTextRows As Integer
Dim strDataShortText As String
Dim strKeyword_A As String
Dim strKeyword_B As String
Dim strKeyword_C As String
Dim strCheck_B As String
Dim strCheck_C As String
Dim lastRow
Dim i As Integer
lastRow = Data.Cells(Rows.Count, 1).End(xlUp).Row
For intLoopKeywordsRows = 2 To lastRow
For intLoopDataShortTextRows = 2 To lastRow
'==================================================================================
'==================================================================================
If Data.Range("S" & intLoopDataShortTextRows) = "" Then '===========only if column S is blank
strDataShortText = Trim(UCase(Data.Range("G" & intLoopDataShortTextRows)))
strKeyword_A = UCase(wsKeywords.Range("A" & intLoopKeywordsRows))
strCheck_B = ""
If Left(wsKeywords.Range("B" & intLoopKeywordsRows), 1) = "-" Then
strCheck_B = "Neg"
strKeyword_B = UCase(Right(wsKeywords.Range("B" & intLoopKeywordsRows), Len(wsKeywords.Range("B" & intLoopKeywordsRows)) - 1))
ElseIf wsKeywords.Range("B" & intLoopKeywordsRows) <> "" Then
strCheck_B = "Pos"
strKeyword_B = UCase(wsKeywords.Range("B" & intLoopKeywordsRows))
End If
strCheck_C = ""
If Left(wsKeywords.Range("C" & intLoopKeywordsRows), 1) = "-" Then
strCheck_C = "Neg"
strKeyword_C = UCase(Right(wsKeywords.Range("C" & intLoopKeywordsRows), Len(wsKeywords.Range("C" & intLoopKeywordsRows)) - 1))
ElseIf wsKeywords.Range("C" & intLoopKeywordsRows) <> "" Then
strCheck_C = "Pos"
strKeyword_C = UCase(wsKeywords.Range("C" & intLoopKeywordsRows))
End If
Dim Check_JumpLoop As Integer
Check_JumpLoop = 0
'================if negative values found then go to next Data Text======================
If (strCheck_B = "Neg" And InStr(strDataShortText, strKeyword_B) > 0) Or (strCheck_C = "Neg" And InStr(strDataShortText, strKeyword_C) > 0) Then
Check_JumpLoop = 1
End If
'########################################################################################
'========================================================================================
If Check_JumpLoop = 0 Then
If strCheck_B = "Pos" And strCheck_C = "Pos" Then
If InStr(strDataShortText, strKeyword_A) > 0 And InStr(strDataShortText, strKeyword_B) > 0 And InStr(strDataShortText, strKeyword_C) > 0 Then
Data.Range("S" & intLoopDataShortTextRows) = wsKeywords.Range("E" & intLoopKeywordsRows)
End If
ElseIf strCheck_B = "Pos" And strCheck_C <> "Pos" Then
If InStr(strDataShortText, strKeyword_A) > 0 And InStr(strDataShortText, strKeyword_B) > 0 Then
Data.Range("S" & intLoopDataShortTextRows) = wsKeywords.Range("E" & intLoopKeywordsRows)
End If
ElseIf strCheck_B <> "Pos" And strCheck_C = "Pos" Then
If InStr(strDataShortText, strKeyword_A) > 0 And InStr(strDataShortText, strKeyword_C) > 0 Then
Data.Range("S" & intLoopDataShortTextRows) = wsKeywords.Range("E" & intLoopKeywordsRows)
End If
ElseIf strCheck_B <> "Pos" And strCheck_C <> "Pos" Then
If InStr(strDataShortText, strKeyword_A) > 0 Then
Data.Range("S" & intLoopDataShortTextRows) = wsKeywords.Range("E" & intLoopKeywordsRows)
End If
End If
End If
'########################################################################################
End If
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Next intLoopDataShortTextRows
Next intLoopKeywordsRows
My question is whether there is a faster / more efficient way of doing this?
EDIT: DATA DESCRIPTION
The data column contains descriptions, such as "Green Garden Hose".
The Keywords sheet contains three columns for entering keywords. These are singular words such as "HOSE", "GREEN", and "GARDEN". To match a keyword to a Value (which in this case is numeric), it must match all keywords in the three columns, but the columns do not need to be filled. If there is only 1 keyword, only that keyword will be looked for. If there is two keywords in two of the columns, the description must contain both etc.
Placing a "-" before a keyword means that the keyword must now be excluded for the value to be assigned. E.G. say the description is "Blue Panel", and the first two keyword columns contains "PANEL" and "-BLUE", the value would not be assigned as BLUE must be excluded from the description.
Related
This question already has answers here:
Excel UDF for capturing numbers within characters
(4 answers)
Closed 4 years ago.
I need to extract the numbers from a string of text and I'm not quite sure how to do it. The code I've attached below is very preliminary and most likely can be done more elegantly. A sample of the string I'm trying to parse is as follows:
"ID CSys ID Set ID Set Value Set Title 7026..Plate Top MajorPrn Stress 7027..Plate Top MinorPrn Stress 7033..Plate Top VonMises Stress"
I need to pull the numbers 7026, 7027, and 7033. The string will vary in length and the number of values that I'll need to pull will also vary. Any help would be much appreciated. Thanks!
Dim WrdArray() As String
Dim txtstrm As TextStream
Dim line As String
Dim clm As Long
Dim Rw As Long
'------------------------------------------------------------
Dim i As Long
Dim strPath As String
Dim strLine As String
Dim count, count1 As Integer
Dim holder As String
Dim smallSample As String
count = 0
count1 = 1
holder = ""
'Remove Filters and Add Custom Filters
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Text Files", "*.txt")
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Dat Files", "*.dat")
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
End If
'------------------------------------------------------------
If strPath <> "" Then
Set txtstrm = FSO.OpenTextFile(strPath)
Else
MsgBox "No file selected.", vbExclamation
Exit Sub
End If
Rw = 1
Do Until txtstrm.AtEndOfStream
line = txtstrm.ReadLine
clm = 1
WrdArray() = Split(line, " ") 'Change with ; if required
For Each wrd In WrdArray()
If Rw = 1 Then
Do While count <> Len(wrd)
smallSample = Left(wrd, 1)
If smallSample = "0" Or smallSample = "1" Or smallSample = "2" Or smallSample = "3" Or smallSample = "4" _
Or smallSample = "5" Or smallSample = "6" Or smallSample = "7" Or smallSample = "8" _
Or smallSample = "9" Then
holder = holder & smallSample
Else
If holder <> "" Then
Cells(count1, 1) = holder
count1 = count1 + 1
End If
holder = ""
End If
wrd = Right(wrd, Len(wrd) - 1)
clm = clm + 4
ActiveSheet.Cells(Rw, clm) = holder
Loop
Else
ActiveSheet.Cells(Rw, clm) = wrd
clm = clm + 1
End If
Next wrd
Rw = Rw + 1
Loop
txtstrm.Close
End Sub
You can use Regular Expressions.
Sub ExtractNumbers()
Dim str As String, regex As regExp, matches As MatchCollection, match As match
str = "ID CSys ID Set ID Set Value Set Title 7026..Plate Top MajorPrn Stress 7027..Plate Top MinorPrn Stress 7033..Plate Top VonMises Stress"
Set regex = New regExp
regex.Pattern = "\d+" '~~~> Look for variable length numbers only
regex.Global = True
If (regex.Test(str) = True) Then
Set matches = regex.Execute(str) '~~~> Execute search
For Each match In matches
Debug.Print match.Value '~~~> Prints: 7026, 7027, 7033
Next
End If
End Sub
Make sure you reference the VBA regex library:
Open VBA editor
Tools > References...
Check Microsoft VBScript Regular Expression 5.5
To exact numbers in the form you want, try something like:
Sub dural()
Dim s As String, i As Long, L As Long, c As String, temp As String
s = [A1]
L = Len(s)
temp = ""
For i = 1 To L
c = Mid(s, i, 1)
If c Like "[0-9]" Then
temp = temp & c
Else
temp = temp & " "
End If
Next i
temp = "'" & Application.WorksheetFunction.Trim(temp)
temp = Replace(temp, " ", ",")
[B1] = temp
End Sub
You can use this function that splits the "words and test for numeric:
Function numfromstring(str As String) As String
Dim strarr() As String
str = Replace(str, ".", " ")
strarr = Split(str)
Dim i As Long
For i = 0 To UBound(strarr)
If IsNumeric(strarr(i)) Then
numfromstring = numfromstring & "," & strarr(i)
End If
Next i
numfromstring = Mid(numfromstring, 2)
End Function
You would call it from the worksheet with a formula:
=numfromstring(A1)
Or from vba like this:
Sub try()
Dim str As String
str = "ID CSys ID Set ID Set Value Set Title 7026..Plate Top MajorPrn Stress 7027..Plate Top MinorPrn Stress 7033..Plate Top VonMises Stress"
Dim out As String
out = numfromstring(str)
Debug.Print out
End Sub
If you have Office 365 Excel you can use this array formula:
=TEXTJOIN(",",TRUE,IF(ISNUMBER(--TRIM(MID(SUBSTITUTE(SUBSTITUTE(A1,"."," ")," ",REPT(" ",99)),(ROW($1:$100)-1)*99+1,99))),TRIM(MID(SUBSTITUTE(SUBSTITUTE(A1,"."," ")," ",REPT(" ",99)),(ROW($1:$100)-1)*99+1,99)),""))
Being an array formula it needs to be confirmed with Ctrl-Shift-Enter instead of Enter when exiting edit mode:
I was wondering how to remove duplicate names/text's in a cell. For example
Jean Donea Jean Doneasee
R.L. Foye R.L. Foyesee
J.E. Zimmer J.E. Zimmersee
R.P. Reed R.P. Reedsee D.E. Munson D.E. Munsonsee
While googling, I stumbled upon a macro/code, it's like:
Function RemoveDupes1(pWorkRng As Range) As String
'Updateby20140924
Dim xValue As String
Dim xChar As String
Dim xOutValue As String
Set xDic = CreateObject("Scripting.Dictionary")
xValue = pWorkRng.Value
For i = 1 To VBA.Len(xValue)
xChar = VBA.Mid(xValue, i, 1)
If xDic.exists(xChar) Then
Else
xDic(xChar) = ""
xOutValue = xOutValue & xChar
End If
Next
RemoveDupes1 = xOutValue
End Function
The macro is working, but it is comparing every letter, and if it finds any repeated letters, it's removing that.
When I use the code over those names, the result is somewhat like this:
Jean Dos
R.L Foyes
J.E Zimers
R.P edsDEMuno
By looking at the result I can make out it is not what I want, yet I got no clue how to correct the code.
The desired output should look like:
Jean Donea
R.L. Foye
J.E. Zimmer
R.P. Reed
Any suggestions?
Thanks in Advance.
Input
With the input on the image:
Result
The Debug.Print output
Regex
A regex can be used dynamically iterating on the cell, to work as a Find tool. So it will extract only the shortest match. \w*( OUTPUT_OF_EXTRACTELEMENT )\w*, e.g.: \w*(Jean)\w*
The Regex's reference must be enabled.
Code
Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
On Error GoTo ErrHandler:
EXTRACTELEMENT = Split(Application.Trim(Mid(Txt, 1)), Separator)(n - 1)
Exit Function
ErrHandler:
' error handling code
EXTRACTELEMENT = 0
On Error GoTo 0
End Function
Sub test()
Dim str As String
Dim objMatches As Object
Set objRegExp = CreateObject("VBScript.RegExp") 'New regexp
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For Row = 1 To lastrow
str = Range("A" & Row)
F_str = ""
N_Elements = UBound(Split(str, " "))
If N_Elements > 0 Then
For k = 1 To N_Elements + 1
strPattern = "\w*(" & EXTRACTELEMENT(CStr(str), k, " ") & ")\w*"
With objRegExp
.Pattern = strPattern
.Global = True
End With
If objRegExp.test(strPattern) Then
Set objMatches = objRegExp.Execute(str)
If objMatches.Count > 1 Then
If objRegExp.test(F_str) = False Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
ElseIf k <= 2 And objMatches.Count = 1 Then
F_str = F_str & " " & objMatches(0).Submatches(0)
End If
End If
Next k
Else
F_str = str
End If
Debug.Print Trim(F_str)
Next Row
End Sub
Note that you can Replace the Debug.Print to write on the target
cell, if it is column B to Cells(Row,2)=Trim(F_str)
Explanation
Function
You can use this UDF, that uses the Split Function to obtain the element separated by spaces (" "). So it can get every element to compare on the cell.
Loops
It will loop from 1 to the number of elements k in each cell and from row 1 to lastrow.
Regex
The Regex is used to find the matches on the cell and Join a new string with the shortest element of each match.
This solution operates on the assumption that 'see' (or some other three-letter string) will always be on the end of the cell value. If that isn't the case then this won't work.
Function RemoveDupeInCell(dString As String) As String
Dim x As Long, ct As Long
Dim str As String
'define str as half the length of the cell, minus the right three characters
str = Trim(Left(dString, WorksheetFunction.RoundUp((Len(dString) - 3) / 2, 0)))
'loop through the entire cell and count the number of instances of str
For x = 1 To Len(dString)
If Mid(dString, x, Len(str)) = str Then ct = ct + 1
Next x
'if it's more than one, set to str, otherwise error
If ct > 1 Then
RemoveDupeInCell = str
Else
RemoveDupeInCell = "#N/A"
End If
End Function
I have an Excel sheet with a column containing texts like "Hello there 2005 A" I want to split this text in between two columns, one containing 'Hello there 2005' and the other saying 'A'.
I have tried Split function in VBA, but I can't make it loop through the entire column or even come up with a delimeter which will split exactly before the letter 'A'.
Results should look something like this:
try this
Option Explicit
Sub main()
Dim cell As Range
Dim strng As Variant
Dim rightStrng As String
Dim i As Long
With Worksheets("multimanager") '<== change it as per your needs
For Each cell In .Columns("A").SpecialCells(xlCellTypeConstants, xlTextValues) 'assuming that "column containing texts" is column "A"
strng = Split(cell)
rightStrng = ""
i = UBound(strng)
Do While Not IsNumeric(strng(i)) And i > 0
rightStrng = strng(i) & " " & rightStrng
i = i - 1
Loop
If IsNumeric(strng(i)) Then
rightStrng = Application.WorksheetFunction.Trim(rightStrng)
cell.Offset(, 2) = rightStrng
cell.Offset(, 1) = Left(cell.Value, IIf(rightStrng <> "", InStrRev(cell.Value, rightStrng) - 2, Len(cell.Value)))
End If
Next cell
End With
End Sub
Instr(cellValue," ")
will give you the position of your first space
firstPos = instr(cellValue," ") ' first space
secondPos = instr(firstPos + 1, cellValue, " ") ' second space
etc..
or
followed by mid, and replace
secondColumnValue = mid(cellValue, thirdPos + 1)
firstColumnValue = replace(cellValue, secondColumnValue, "")
I have a column of something that would be like XXX US, and I want to return XXX for the cell. I want to make a macro that deletes the whole column with one click. For some reason my ticker part of my code throws an error, but when i don't use a loop it works. Is there anything I can do?
Sub DEAS()
Dim cellText As String
Dim ticker As String
Dim i As Integer
i = 5
Do While i < 8000
cellText = Cells(i, 1).Value
ticker = Left(cellText, InStr(cellText, " ") - 1)
Cells(i, 1).Value = ticker
i = i + 1
Loop
End Sub
Give this a try:
Sub DEAS()
Dim cellText As String
Dim ticker As String
Dim i As Integer
i = 5
Do While i < 8000
cellText = Cells(i, 1).Value
If InStr(cellText, " ") > 0 Then
Cells(i, 1).Value = Split(cellText, " ")(0)
End If
i = i + 1
Loop
End Sub
Left(cellText, InStr(cellText, " ") - 1) will throw an error 5 "Invalid procedure call or argument" if the cellText doesn't contain a space. This is most likely due to encountering a value somewhere in A5:A8000 that either isn't in the expected format or is empty. In that case, Instr will return 0, which makes your call evaluate to Left(cellText, -1). You need to check the return value first (note that you can also use a For loop - IMHO more readable when your conditions are fixed):
Sub DEAS()
Dim cellText As String
Dim ticker As String
Dim i As Integer
Dim pos As Integer
For i = 5 To 8000
cellText = Cells(i, 1).Value
pos = InStr(cellText, " ")
If pos > 0 Then
ticker = Left(cellText, pos - 1)
Cells(i, 1).Value = ticker
End If
Next i
End Sub
I'm working with the worksheetfunction.averageifs() and worksheetfunction.countifs() functions.
I have some conditionals that specify what criteria should be looked for, so I'd like to just have an array that could be added new criteria to, so that instead of a series of cluttered conditionals:
If (dep = 0) Then
sortspg = True
colcount = .CountIfs(column, "<3", badCol, "1")
If (colcount > 0) Then
colavg = .AverageIfs(column, column, "<3", badCol, "1")
insert = True
Else
insert = False
End If
Else
colcount = .CountIfs(column, "<3", DepColumn, dep, badCol, "1")
If colcount > 0 Then
colavg = .AverageIfs(column, column, "<3", DepColumn, dep, badCol, "1")
insert = True
Else
insert = False
End If
End If
I could just pass an array like:
CondArray(column => "<3", DepColumn => dep)
If colCount > 0 Then
CondArray[] = (badCol => "1")
and then
.CountIfs(CondArray)
.AverageIfs(column, CondArray)
You can build it using a For...Next Loop to setup the formula, and the Evaluate function.
Sub Build_Formula()
'http://stackoverflow.com/questions/15317466/vba-excel-array-of-criteria-for-if-functions
Dim i As Long, lOutput As Long
Dim strTempArr As String
Dim CondArray() As Variant
Dim StrFormulaBuildUp As String
Dim rng As Range
'Modify constant with applicable formula worksheet function
Const STRFORMULASTART As String = "CountIfs("
'Note used this for test data; edit as applicable
Set rng = Cells.CurrentRegion
'Build array holding conditions; the way the loop is structured is for
'the "COUNTIF" function; modify as necessary
CondArray = Array(rng, "<3")
StrFormulaBuildUp = STRFORMULASTART
'Begin loop to build formula
For i = LBound(CondArray) To UBound(CondArray)
'Test if value in condition array is a range
'if yes set the range address to a string
If TypeName(CondArray(i)) = "Range" Then
strTempArr = CStr(CondArray(i).Address)
Else
'If condtion, then add quote marks
strTempArr = Chr(34) & CStr(CondArray(i)) & Chr(34)
End If
StrFormulaBuildUp = StrFormulaBuildUp & strTempArr & ","
Next i
'Remove extra "," from string and close formula
StrFormulaBuildUp = Left(StrFormulaBuildUp, Len(StrFormulaBuildUp) - 1) & ")"
'Determine forumla value
lOutput = Evaluate(StrFormulaBuildUp)
MsgBox lOutput
End Sub