I have multiple rows with some words separeted by semicolons(;), and need to count how many times a certain word appears in Column A cell strings of Sheet1.
Using two rows for example:
Column "A"
Banana; Apple; Orange
Banana; Banana; Apple
I came up with this code for the counting of the specific word I want to count:
Sub count()
'The count will be registered in "B6"
strcount = "Banana"
For i = 2 to 30
If InStr(Sheets("Sheet1").Cells(i, "A").Text, strcount) <> 0 Then
Cells(6, "B").Value = Cells(6, "B").Value + 1
End If
Next i
End Sub
The problem with this code is that it doesn't recognize the 2 appearences of "Banana" in the second row returning me a count of 2 instead of 3:
Results for each fruit:
Banana: 2
Apple: 2
Orange: 1
I see that the problem is InStr only recognizes if the string is there, but how can I overcome this?
Solution:
Both basodre's and Алексей's answers worked.
For basodre's code I had to change only the delimiter from ";" to "; " (with a space after the semicolon) to match my string.
aFoods = Split(rIterator.Value, "; ")
Алексей's answer works perfectly too, but by the time of this edit is limited for Excel 2019 or above, given it uses the "TEXTJOIN" function and I couldn't come up with a replacement for that.
Here's an example that I think does what you need. Please review, modify to your range, and let us know if it works.
Sub CountWords()
Dim rng As Range
Dim aFoods As Variant
Dim rIterator As Range
Dim counter As Long
Const theFood As String = "Banana"
Set rng = Range("A1:A3")
counter = 0
For Each rIterator In rng
aFoods = Split(rIterator.Value, ";")
For i = LBound(aFoods) To UBound(aFoods)
If aFoods(i) = theFood Then
counter = counter + 1
End If
Next i
Next rIterator
Debug.Print counter
End Sub
Solution with RegExp:
Option Explicit
Sub test1()
Dim re As Object, result As Object, text As String, fruit As Variant
Set re = CreateObject("vbscript.regexp")
re.Global = True
text = WorksheetFunction.TextJoin(";", True, Columns("A"))
'In Excel < 2019 you can use: text = Join(WorksheetFunction.Transpose(Intersect(Columns("A"), ActiveSheet.UsedRange)), ";")
For Each fruit In Array("Banana", "Apple", "Orange")
re.Pattern = "\b" & fruit & "\b"
Set result = re.Execute(text)
Debug.Print "Amount of [" & fruit & "] = " & result.Count
Next
End Sub
Output:
Amount of [Banana] = 3
Amount of [Apple] = 2
Amount of [Orange] = 1
Using regular expression
Sub FindEntries()
Dim mc, rw
Const word$ = "Banana"
With CreateObject("VBScript.RegExp")
.IgnoreCase = True: .Global = True: .Pattern = "(^|;\s+)" & word & "(?=;|$)"
For rw = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Set mc = .Execute(Cells(rw, "A")): [B6] = [B6] + mc.Count
Next
End With
End Sub
Related
I wrote a Sub which looks for the Search Terms from one sheet, and captures each line from a big array of strings which contains one of those terms (printing it to another sheet).
Originally I had it written like this:
For each Search Term, look at each line in the file and print each match.
It worked, but it meant that if one line contained multiple Search Terms, it would get printed as many times. I wanted to eliminate that, just printing the line once if it contained at least one Search Term. So, I rearranged the code to work like this:
For each line in the file, look at each Search Term and print the line if it matches.
(and if you do get a match, skip the remaining Search Terms for that line)
If anything, this way should be slightly more efficient than the original, I thought...
And yet, after I rearranged the code, it takes much longer to execute.
I guess this means that, though I feel as though I'm doing the same things in a different order, and even saving some unnecessary checks, I must be somehow compounding the parts that take the longest. Can anyone shed some light and help me understand how I've made the code so much worse?
Here's what the two versions of the relevant code segment look like:
Original way:
searchTermRow = firstSearchTermRow
While ActiveWorkbook.Sheets("SearchTerms").Cells(searchTermRow, 1) <> ""
term = ActiveWorkbook.Sheets("SearchTerms").Cells(searchTermRow, 1)
For j = 1 To UBound(bigStringArray) - 1
counter = counter + 1
If (InStr(bigStringArray(j), term) <> 0) Then
Cells(resultsRow, 1).Value = bigStringArray(j)
resultsRow = resultsRow + 1
End If
Next j
searchTermRow = searchTermRow + 1
Wend
Rearranged:
For j = 1 To UBound(bigStringArray) - 1
searchTermRow = firstSearchTermRow
Do While ActiveWorkbook.Sheets("SearchTerms").Cells(searchTermRow, 1) <> ""
term = ActiveWorkbook.Sheets("SearchTerms").Cells(searchTermRow, 1)
counter = counter + 1
If (InStr(bigStringArray(j), term) <> 0) Then
Cells(resultsRow, 1).Value = bigStringArray(j)
resultsRow = resultsRow + 1
Exit Do
End If
searchTermRow = searchTermRow + 1
Loop
Next j
bigStringArray is a large array of strings which consists of every line from a file.
counter is just there so that I could count how many checks were done.
You can do one pass through the bigStringArray by using a regular expression with a pattern such as term1|term2|term3 etc.
Option Explicit
Sub RegexMatch()
Const firstSearchTermRow = 2
Dim ws As Worksheet
Dim lastRow As Long, resultsRow As Long, j As Long
Dim rngTerms As Range, t0 As Single: t0 = Timer
Set ws = ActiveWorkbook.Sheets("SearchTerms")
lastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
' build regex pattern
Dim sPattern As String
Set rngTerms = ws.Range("A" & firstSearchTermRow & ":A" & lastRow)
sPattern = Join(WorksheetFunction.Transpose(rngTerms), "|")
'Debug.Print sPattern
Dim regex As Object, m As Object
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = False
.MultiLine = False
.IgnoreCase = True
.Pattern = "(" & sPattern & ")"
End With
' test data
Dim bigStringArray
bigStringArray = Array("", "ABCDE", "BCDEF", "CDEFGH", "DEFHIJKL")
resultsRow = 1
For j = 1 To UBound(bigStringArray)
If regex.test(bigStringArray(j)) Then
Set m = regex.Execute(bigStringArray(j)) ' match
Cells(resultsRow, 1).Value = bigStringArray(j)
Cells(resultsRow, 2).Value = m(0) ' matched term
resultsRow = resultsRow + 1
End If
Next
MsgBox j - 1 & " strings checked", vbInformation, Format(Timer - t0, "0.00 secs")
End Sub
I am trying to extract a substring which has a random position from different strings. The substing is not a fixed value but a "T" and then four numberals e.g. T6000.
As you can see in this image there are a number of machines names where most of them contain a T number. The T number is also different in almost all of the cases. The column of the machines names is "E". First number (T6000) is in E16, last is in E25.
Using my code:
For Ipattern = 16 To NumofMachines + 15 Step 1
TNUMcell = Dsht.Range("E" & Ipattern).Value
'Verify if string contains a Tnum
TNUMLikeBoolean = TNUMcell Like "*T###*"
If TNUMLikeBoolean = True Then
Do Until TNUMdone = True
TNUMchar1 = InStr(TNUMcell, "T") + 1
TNUMcharV = Mid(TNUMcell, TNUMchar1)
TNUMchecknum = IsNumeric(TNUMcharV)
If TNUMchecknum = True Then
Dsht.Range("F" & Ipattern).Value = "T" & Mid(TNUMcell, TNUMchar1, 5)
TNUMdone = True
End If
Loop
Else
Dsht.Range("F" & Ipattern).Value = "NO T"
End If
Next Ipattern
It only fills in the first and the last cell of the 'export' range (F16:F25).
I have been searching for an answer quite some time. As I am (obviously) not a VBA expert.
What am I doing wrong? Why is not filling in the other values?
Thanks,
Wouter J
Try this code
Sub Test()
Dim r As Range, i As Long, c As Long
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "T\d{4}"
For Each r In Range("E16", Range("E" & Rows.Count).End(xlUp))
c = 6
If .Test(r.Value) Then
For i = 0 To .Execute(r.Value).Count - 1
Cells(r.Row, c).Value = .Execute(r.Value)(i)
c = c + 1
Next i
End If
Next r
End With
End Sub
The problem is with your variable TNUMdone.
This is set to True on the first iteration of the loop and then never again set to False, so this code after Do Until TNUMdone = True never runs again.
At the start of your loop, just set TNUMdone to False and it should work:
For Ipattern = 16 To NumofMachines + 15 Step 1
TNUMdone = False
TNUMcell = Dsht.Range("E" & Ipattern).Value
...
I'm facing a problem as a non dev. I have a column in Excel that contains info as such:
46843 xxxx xxx x
xxxx 65483 xxxx
xxxx xxx 65432 xxxxx 4 xx
"x" being normal caracters.
What I want is to be able to extract only the numbers of five digits only.
I started something like this but struggle to put a loop so that it scans all the string:
Function test()
val_in = "rue 4 qsdqsd CURIE 38320 EYBENS"
Filte = Left(val_in, 5)
If IsNumeric(Filte) Then
test = Left(val_in, 5)
Else
sp1 = InStr(1, val_in, " ")
sp2 = InStr(sp1 + 1, val_in, " ")
spt = sp2 + sp1
If spt > 5 Then
extr = Mid(val_in, spt, 5)
End If
End If
End Function
How could I turn the part after "Else" into a loop so that it would scan every space of the string and extract only the numbers that contains 5 digits?
Using regex
Option Explicit
Public Function GetNumbers(ByVal rng As Range) As Variant
Dim arr() As String, i As Long, matches As Object, re As Object
Set re = CreateObject("VBScript.RegExp")
With re
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "\b\d{5}\b"
If .test(rng.Value) Then
Set matches = .Execute(rng.Value)
ReDim arr(0 To matches.Count - 1)
For i = LBound(arr) To UBound(arr)
arr(i) = matches(i)
Next i
Else
arr(i) = rng.Value
End If
End With
GetNumbers = Join(arr, ",")
End Function
Data:
If there is more than one match a comma separated list is returned.
Sub TestMe()
Dim valIn As String
valIn = "rue 4 qsdqsd CURIE 38320 EYBENS 43443"
Dim i As Long
Dim splitted As Variant
splitted = Split(valIn)
For i = LBound(splitted) To UBound(splitted)
If IsNumeric(splitted(i)) And Len(splitted(i)) = 5 Then
Debug.Print splitted(i)
End If
Next i
End Sub
Considering that in your example you mean that the 5 digit numbers are splitted by space, the above works. It splits the string by space to an array and loops through the elements of the array. If the element is with 5 chars and is numeric, it prints it.
If the rule for the spaces is not something that one can count on, here is a different implementation:
Sub TestMe()
Dim valIn As String
valIn = "44244rue4qsdqsdCURIE383201EYBENS43443"
Dim i As Long
For i = 1 To Len(valIn) - 4
If IsNumeric(Mid(valIn, i, 5)) Then
Debug.Print Mid(valIn, i, 5)
End If
Next i
End Sub
It starts looping through the string, checking whether each 5 chars are numeric. When you have numeric 6 chars, it gives two results - 1 to 5 and 2 to 6. Thus 383201 is "translated" as the following 2:
38320
83201
If you have always space between words/numbers then this should do
Sub test()
Dim TestStr As String
Dim Temp As Variant
Dim i As Long, FoundVal As Long
TestStr = "rue 4 qsdqsd CURIE 38320 EYBENS"
Temp = Split(TestStr, " ")
For i = 0 To UBound(Temp)
If Len(Trim(Temp(i))) = 5 And IsNumeric(Temp(i)) Then
FoundVal = Temp(i)
MsgBox FoundVal
End If
Next i
End Sub
From the solution you are trying to apply (creating custom function in VBA) I understand that you actually need to use it in a formula.
To find number with five digits from cell A1 you can use the following formula without VBA:
=IF(ISERROR(FIND("0"&REPT("1",5)&"0",CONCAT(0+(ISNUMBER(-MID(" "&A1&" ",ROW(INDIRECT("1:"&LEN(A1)+2)),1))+0)))),"",MID(A1,FIND("0"&REPT("1",5)&"0",CONCAT(0+(ISNUMBER(-MID(" "&A1&" ",ROW(INDIRECT("1:"&LEN(A1)+2)),1))+0))),5))
To search for other number of digits change the three occurrences of number 5 to your desired digits count in the formula.
Basically I have 7 cells that could be populated with text (b2, b4, b6, b8, b10, b12 and b14). I want to the code to check each of the cells to see if they have a value and send only the cells that do have a value in an email. For formatting purposes the cells pasted into the email need to have one empty cell in between and the cells need to be kept in the order they are in originally, just without the unnecessary blank cells.
I've never officially learned VBA I've only taught myself on a case by case scenario so there could be an easy solution that I'm missing. Often I can debug and find the problem but in this case Excel completely freezes and turns "Not Responding". I have a feeling that means I've got a loop somewhere unresolved but I don't really understand how. The code -seems- to run up until Range("A2").Value = Line(LineCount1). Any suggestions would be appreciated.
Public Sub SingleEmail()
Dim LineCount1 As Integer
Dim LineCount2 As Integer
Dim LineCount3 As Integer
Dim LineCount4 As Integer
Dim LineCount5 As Integer
Dim LineCount6 As Integer
Dim LineCount7 As Integer
Dim NumOfLines As Integer
Range("A2", "A14").ClearContents
LineCount1 = 2
Range("A2").Value = Line(LineCount1)
LineCount2 = 2 + LineCount1
Range("A4").Value = Line(LineCount2)
LineCount3 = 2 + LineCount2
Range("A6").Value = Line(LineCount3)
LineCount4 = 2 + LineCount3
Range("A8").Value = Line(LineCount4)
LineCount5 = 2 + LineCount4
Range("A10").Value = Line(LineCount5)
LineCount6 = 2 + LineCount5
Range("A12").Value = Line(LineCount6)
LineCount7 = 2 + LineCount6
Range("A14").Value = Line(LineCount7)
NumOfLines = Range("n3").Value
If Range("A2") <> "" Then
Range("A2", "A" & NumOfLines).Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = ""
.Item.To = "personalemailaddress#Someplace.com"
.Item.CC = ""
.Item.Subject = "Email Subject"
.Item.send
End With
End If
End Sub
Function Line(ByRef LineCount As Integer) As String
Line = ""
Do While Line = "" Or LineCount < 13
If Range("B" & LineCount).Value <> "" Then
Line = Range("B" & LineCount).Value
Else
LineCount = LineCount + 2
End If
Loop
End Function
To answer your question:
If B4 has value and B2 is blank then this While loop become infinite. the LineCount is Stuck on 4, hence no overflow. That's why your code freezes.
Why are you running a loop in the first place. You can simply assign the values like this Range("A2:A14").Value =Range("B2:B14").Value
As per your comment, you need to use And operator in place of OR
Do While Line = "" And LineCount < 13 now the loop will exit if line <> "" or LineCount > 14
I have a spreadsheet with 4 columns and 35000 lines.
I have made a form with 3 listboxes (among other buttons)
When I click search button I would like to search column A for all occurrences of the number and fill the listboxes with the corresponding B, C & D
(if it helps speed there will never be more than 10 occurrences of the same number and column A is sorted)
123 dog Fido Elm $50
123 dog Spot Oak $40
456 Cat Jet Adam $30
Search for 123 and
listbox 1 will show Fido & Spot
listbox 2 will show Elm & Oak
listbox3 ....
Code so far:
Private Sub cmdSearch_Click()
Dim Response As Long
Dim NotFound As Integer
NotFound = 0
ActiveWorkbook.Sheets("test").Activate
Frame1.Visible = False
Response = txtItemNumber.Text
If Response <> False Then
Range("A2").Select
Do Until ActiveCell.Value = Val(Response)
If ActiveCell.Value = "" Then
MsgBox "Item Number Not Found!", vbExclamation
NotFound = 1
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
If ActiveCell.Value = Val(Response) Then
Frame1.Visible = True
ListBox1.Text = ActiveCell.Offset(0, 1)
ListBox2.Text = ActiveCell.Offset(0, 2)
ListBox3.Text = ActiveCell.Offset(0, 3)
**'would like to see if next number in Column A is also the same as being searched... if so then add to listbox'
'do this until the next number doesn't match'**
End If
End If
End Sub
also would the process be sped up with an array or vlookup? I'm not to familiar with those
and I would like the multiple list boxes rather than a multicolumn list box (in case that comes up)
This code is based on your idea but it uses an array, called arr, to input the data quickly and to facilitate fast processing. The located references are stored in strings which are split later into the ListBoxes.
A vertical bar is used as a split character. If that clashes with your data you will need to change it.
Note: I don't think your Frame1.Visible commands are effective.actually do anything.
Private Sub cmdSearch_Click()
Dim Response As Long
Dim NotFound As Integer
Dim arr As Variant
Dim i As Long
Dim str1 As String, str2 As String, str3 As String
NotFound = 0
ActiveWorkbook.Sheets("test").Activate
Frame1.Visible = False
Response = txtItemNumber.Text
If Response <> False Then
With ActiveSheet
arr = .Range("A2:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With
For i = 1 To UBound(arr)
If arr(i, 1) = Response Then
str1 = IIf(str1 = "", arr(i, 2), str1 & "|" & arr(i, 2))
str2 = IIf(str2 = "", arr(i, 3), str2 & "|" & arr(i, 3))
str3 = IIf(str3 = "", arr(i, 4), str3 & "|" & arr(i, 4))
End If
Next
If str1 = "" Then
MsgBox "Item Number Not Found!", vbExclamation
NotFound = 1
Else
Frame1.Visible = True
ListBox1.List = Split(str1, "|")
ListBox2.List = Split(str2, "|")
ListBox3.List = Split(str3, "|")
End If
End If
End Sub
Just curious, if you define Response as a long, why are you using val(Response) in the while loop? And if its a long, then Response = txtItemNumber.Text could throw an error by potentially trying to store an alphanumeric string in a numeric only long.
Since you dim Response as a long, use this instead...
Response = Val("0" & txtItemNumber.Text)
This assumes no negative numbers. By pre-pending the zero you don't change the value of the number (0100 is still 100) but you also handle "0abc" issues if the user enters text. It will return 0 if the user enters "abc" and your solution checks for 0 (false) already. If the user enters "100" it converts "0100" to 100 and your solution then moves on with that value. It will fail if the user enters "-100" since "0-100" isn't 100.
Now, since we are using a long, remove all references to Val(Response) elsewhere. This will reduce the type conversions inside the loop that searches for the cell value. As you have it, each time through the loop it converts Response from a long to a string then to a long and then does the UNTIL compare. And it does that 35000 times.
By converting it using Val before the loop, it now does the string to long conversion ONCE instead of all 35000 times it loops going through the cells. Its a minor change that could speed it up a bit.