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
...
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'm having trouble with confirming if any cell in a specified range contains any value. Hoping someone can help me out with the syntax.
Thanks in advance
For i = 1 To DataRange.Rows.Count
CheckCells = If(Qty > 0 And WS1.Range("Sheet1!A" & i & ":Sheet1!Z" & i).Value <> "", "HasValue", "NoValue")
Next i
You could iterate over the cells to examine each one:
Dim r = xl.Range("A1", "D4")
Dim nCells = r.Cells.Count
Dim isAllBlank = True
For i = 1 To nCells
If DirectCast(r.Cells(i), Excel.Range).Value IsNot Nothing Then
isAllBlank = False
Exit For
End If
Next
checkCells = If(isAllBlank, "NoValue", "HasValue")
Where xl.Range is the range you need to check.
I tried to use range.SpecialCells(Excel.XlCellType.xlCellTypeBlanks), but it was a bit moody about it.
I was able to achieve what I wanted by using the following code.
For i = 1 To DataRange.Rows.Count
If xlApp.WorksheetFunction.CountA(WS.Range("Parts!Z" & R & ":Parts!AI" & R)) > 0 Then
CheckCells = "HasValue"
Else
CheckCells = "NoValue"
End If
Next i
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
I want to extract postal code from address. I have tried isNumeric method below to extract 6 numeric from the address. Some of the address got 5 digit and some got 6 digit postal code.
But there is some error where sometimes 11900 only show 1900, 08000 shows 8000, and 4 digit number also show.
Range("A2").Select
i = 2
Do While ActiveCell <> ""
Address = UCase(Trim(Range("C" & CStr(i))) + " " + Trim(Range("D" & CStr(i))) + " " + Trim(Range("E" & CStr(i))) + " " + Trim(Range("F" & CStr(i))))
For p = 1 To Len(Address)
If IsNumeric(Mid(Address , p, 6)) Then
Range("O" & CStr(i)) = Mid(Address, p, 6)
End If
Next p
ActiveCell.Offset(1, 0).Select
i = i + 1
Loop
excel output
Address Postal Code
Wisma Pansar, 23-27 Jln Bengkel P.O. Box 319, 96007 Sibu Sarawak 96007
Wisma Lim , Lot 50A, Sec. 92A, 3.1/2 Sg Besi, 57100 Kuala Lumpur 57100
No. 265A, Jalan Sungai Petani 08300 Gurun Kedah Darul Aman 8300
No. 39, Jalan Nipah, Taman Lip Sin 11900 Sungai Nibong Pulau Pinang 1900
4-G, Lebuh Sungai Pinang 1 Sri Pinang 11600 Jelutong Pulau Pinang 11600
539/2, Gypsum Metropolitan Tower, Rajthevee Bangkok 10400, Thailand 0400,
LOTS 1869 &1938, 18th MILE KAJANG, SEMENYIH ROAD SELANGOR D.E. 1938, *no postal code in address
36a, Joo Chiat Place, Singapore 427760 0
I mean something like this:
Sub test()
Dim c As Range, p As Long, v, addr, i As Long, hit As Boolean
Set c = Range("A2") 'no need to select the cell
Do While c <> ""
addr = c.Value 'using your examples
hit = False
For p = 1 To Len(addr)
'will accept 5 or 6 digits - prefer 6
' so count down...
For i = 6 To 5 Step -1
v = Mid(addr, p, i)
If v Like String(i, "#") Then
c.Offset(0, 1).NumberFormat = "#" 'in case of leading zero
c.Offset(0, 1).Value = v
hit = True
Exit For
End If
Next i
If hit Then Exit For
Next p
Set c = c.Offset(1, 0)
Loop
End Sub
A regular expression approach would probably be much nicer.
To complement #TimWilliams his answer, hereby a solution making use of Array and Regular Expressions (with late binding). So let's immagine the following setup:
Now run the following code:
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.regexp")
'Set up regular expression
RegEx.Pattern = "\d{5,6}"
RegEx.Global = True
'Go through your data and execute RegEx
With Sheet1 'Change according to your sheets CodeName
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:A" & lr).Value
.Range("B2:B" & lr).NumberFormat = "#"
For x = LBound(arr) To UBound(arr)
Set Matches = RegEx.Execute(arr(x, 1))
For Each Match In Matches
.Cells(x + 1, 2) = Match.Value
Next Match
Next x
End With
End Sub
Assuming the possibility of multiple matches within a string, the last match will be used.
If you are sure there can only be one match (or none), then you could also use:
If Matches.Count = 1 Then .Cells(x + 1, 2) = Matches.Item(0)
Instead of:
For Each Match In Matches
.Cells(x + 1, 2) = Match.Value
Next Match
I have a code that searches an excel fill for the word distance, takes the value of the cell next to it, paste it into a new cell, then sums all the cells up. Which works great, but i now need to find a way to only sum ever even row number. Does that make sense?
Sub Distance_Check()
Dim DistanceCheck As String
Dim DistanceNumber As String
Dim DistanceSum As String
Dim DistanceTotal As String
DistanceCheck = MsgBox("Would you like to check the distance?", vbYesNo)
If DistanceCheck = vbYes Then
If IsArray(fname) Then Workbooks.OpenText fname(1)
i = 1
findStr = "Distance"
Set foundCel = Range("A:A").Find(what:=findStr)
If Not foundCel Is Nothing Then
firstAddress = foundCel.Address
Do
Range("J" & i).Value = foundCel.Offset(0, 1).Value
Set foundCel = Range("A:A").FindNext(foundCel)
i = i + 1
Loop While Not foundCel Is Nothing And foundCel.Address <> firstAddress
End If
Set wkbSourceBook = ActiveWorkbook
DistanceNumber = i - 2
DistanceSum = WorksheetFunction.Sum(Range(Cells(2, 15), (Cells(DistanceNumber + 1, 15))))
DistanceTotal = DistanceSum / DistanceNumber
If DistanceNumber = Cells(2, 12) Then
MsgBox ("No error found wihin distance")
Else
MsgBox ("Error found with distance")
End If
Else
End If
Call Save_Data
End Sub
Would the way youd go about this be using a for loop on the
cells(DistanceNumber(j,+1)
Where j = 0,
j = j +2 ,
Until j > DistanceNumber,
Would that work? If so how would you go about it?
Thanks
A quick way to step through a loop in the desired increments is to use the Mod operator which divides two numbers and returns any remainder (e.g. 7 mod 2 = 1, as two sixes fit into seven, leaving one).
You can use the row property of the range you identify with the Find method, and since you want to jump by two the modulo should be zero:
If foundcel.Row Mod 2 = 0 Then Range("J" & i).value = foundcel.Offset(0, 1).Value
That said, there is a 'built in' way to step through a loop if using a For loop like this
For x = 2 to 10 Step 2
' Do stuff
Next x
You can also use this method to step backwards, e.g.
For x = 100 to 0 Step -10
' Do stuff backwards!
Next x