I would like to print each substrings in between the "..." from this string: "...covid...is...very...scary" in consecutive cells in a column in excel.
this is my code in VBA.
Sub copyd()
findandcopy("...covid...is...very...scary") 'not sure how to print in consecutive cells of a column
End Sub
Function findandcopy(brokenstr As String) As String
Dim first, second As Integer
Dim strtarget as string
strtarget = "..."
Do until second =0. 'second=0 so that loop ends when there is no more "..." found
first = InStr(brokenstr, strtarget)
second = InStr(first + 3, brokenstr, strtarget)
findandcopy = Mid(purpose, first +3, second - first -3) 'referred to https://stackoverflow.com/questions/2543225/how-to-get-a-particular-part-of-a-string#_=_
first = second 'so that loop can find next "..."
Loop
End Function
can anyone please advise? thank you for your help :)
Try this code:
Option Explicit
Sub copyd()
Dim arr As Variant
' get splitted text into horizontal array arr()
arr = Split("...covid...is...very...scary", "...")
If UBound(arr) > 0 Then ' if there is something in the array, display it on the sheet
' put onto sheet values from transposed array arr()
ThisWorkbook.Worksheets(1).Range("A1"). _
Resize(UBound(arr) + 1, 1).Value = _
WorksheetFunction.Transpose(arr)
End If
End Sub
Ahh, why not just split the string by "..."?
Like:
Function findandcopy(brokenstr As String, targetStr as string)
dim substr()
if instr(1, brokenstr, targetStr, vbTextCompare) > 0 then
'brokenstr has at least one instance of targetStr in it
brokenstr2 = split(brokenstr,targetStr)
if brokenstr2(0) = "" then
redim substr(ubound(brokenstr2)-1)
iStart = 1
else
redim substr(ubound(brokenstr2))
iStart = 0
end if
for i = iStart to ubound(brokenstr2)
substr(i-iStart) = brokenstr2(i)
next i
else
'No instances of targetStr in brokenstr
redim substr(0)
substr(0) = brokenstr
end if
findandcopy = substr
end function
Which will return an array of strings which are the bits between targetStr. Then you can do with it as you please within the parent sub.
If you start doing comparisons with the results and find issues - you can remove whitespace by modifying above as:
substr(i) = trim(brokenstr2(i))
and your calling code:
Sub main()
Dim covid as string
Dim remove as string
covid = "...covid...is....very...scary"
'covid = "really...covid...is...very...scary" 'For testing
remove = "..."
rtn = findandcopy(covid, remove)
end sub
Related
Does excel vba have a function to sort a given word or string alphabetically? Also, what is this kind of a string manipulation called in technical/programming terms?
For e.g. Word = "Somestring"
Output = "egimnorSst"
Thanks.
If you have Excel O365 with the functions I've used below, you can use this formula:
=TEXTJOIN(,,SORT(MID(A1,SEQUENCE(LEN(A1)),1)))
or as indicated by #JvdV, instead of TEXTJOIN we can use the simpler:
=CONCAT(SORT(MID(A1,SEQUENCE(LEN(A1)),1)))
If y0u don't have those functions, you would need a UDF written in VBA.
Here is one that, since the sort strings should be relatively short, uses a simple Bubblesort to sort the string elements.
Option Explicit
Option Compare Text
Function sortString(S As String) As String
Dim str() As String
Dim I As Long
ReDim str(1 To Len(S))
For I = 1 To Len(S)
str(I) = Mid(S, I, 1)
Next I
BubbleSort str
sortString = Join(str, "")
End Function
Sub BubbleSort(TempArray)
'copied directly from support.microsoft.com
Dim temp As Variant
Dim I As Integer
Dim NoExchanges As Integer
' Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array.
For I = LBound(TempArray) To UBound(TempArray) - 1
' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(I) > TempArray(I + 1) Then
NoExchanges = False
temp = TempArray(I)
TempArray(I) = TempArray(I + 1)
TempArray(I + 1) = temp
End If
Next I
Loop While Not (NoExchanges)
End Sub
Though the question itself is very minimal I would like to answer nonetheless. If you not bothered having S and s reversed than:
Sub Test()
Dim x As Long
Dim str As String: str = "Somestring"
With CreateObject("System.Collections.ArrayList")
For x = 1 To Len(str)
.Add Mid(str, x, 1)
.Sort
Next
Debug.Print Join(.Toarray, "")
End With
End Sub
Results in:
egimnorsSt
If that is not what you want it becomes a bit more complicated I think since we cannot use ASCII codes (S = 83 and way lower than the other characters).
It may not be super pretty but try:
Sub Test()
Dim x As Long
Dim str As String, str_new As String
str = "abcdABCD"
With CreateObject("System.Collections.ArrayList")
For x = 1 To Len(str)
.Add Mid(str, x, 1)
.Sort
Next
str_new = Join(.Toarray, "")
End With
With CreateObject("vbscript.regexp")
.Global = True
.IgnoreCase = True
.Pattern = "([a-z])\1+"
If .Test(str_new) Then
For Each Match In .Execute(str_new)
str_new = Replace(str_new, Match, Application.Proper(Match)) 'Assuming no more than 1 of the same uppercase letters.
Next
End If
End With
Debug.Print str_new
End Sub
Results in:
AaBbCcDd
Another option if you have ExcelO365 with new DA-functions and value in A1:
=CONCAT(SORT(MID(A1,ROW(A1:INDEX(A:A,LEN(A1))),1)))
This would actually return egimnorSst
Another difficult task for me...
I have a excel sheet like this...
In the first column there are two Aas, their values are shown in the second column, which is A string and Astring.
A string and Astring differ only from one blank key. I want to use excel VBA to say, these two values are equal, as long as they are same in the first column, but differ only from one letter in the second column. One of them should be deleted then. [shown in the "target" part]
Similarly, there are two Dds, their values differ only from a ;.
Here I wrote some code, but I dont know how to do the if algorithmus.
Sub deletesimilars()
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
For i = lr To 1 Step -1 'reverse loop
If Cells(i, 1) = Cells(i - 1, 1) Then
' if cells(i,2) ??? cells(i-1,2) then ' I stuck here
Cells(i, 1) = ""
Cells(i, 2) = ""
End If
End If
Next i
End Sub
Thanks!!!
I've run into this previous in my work, when I want to guarantee the "equivalence" of certain string. So my technique is to "normalize" the strings by focusing on the important content of the string.
In most of my cases, this means:
stripping all whitespace (usually not important anyway)
converting everything to lowercase (case is often not important to me)
sometimes ignoring certain special characters
So I have a utility function called NormalizeString that performs these actions.
Your code then becomes:
Option Explicit
Sub DeleteSimilars()
Dim thisSH As Worksheet
Dim lastRow As Long
Set thisSH = ActiveSheet
lastRow = thisSH.UsedRange.Rows.Count
Dim i As Long
For i = lastRow To 2 Step -1
If thisSH.Cells(i, 1) = thisSH.Cells(i - 1, 1) Then
If NormalizeString(thisSH.Cells(i, 2), ";") = _
NormalizeString(thisSH.Cells(i - 1, 2), ";") Then
thisSH.Cells(i, 1) = vbNullString
thisSH.Cells(i, 2) = vbNullString
End If
End If
Next i
End Sub
Function NormalizeString(ByVal inputStr As String, _
Optional ByVal specialChars As String) As String
'--- "normalizes" a string by a series of modifications, such as
' -- removes all whitespace
' -- converts all characters to lowercase
' -- removes other "special" characters that should not
' be considered part of the string
Dim returnString As String
returnString = Replace(inputStr, " ", "", , , vbTextCompare)
returnString = LCase(returnString)
If Not IsMissing(specialChars) Then
Dim i As Integer
For i = 1 To Len(specialChars)
returnString = Replace(returnString, _
Mid(specialChars, i, 1), "", , , vbTextCompare)
Next i
End If
NormalizeString = returnString
End Function
theStr = "KT150"
Characters count is always 5 in total. I want to make sure that there is 3 numbers in theStr. How would I achieve this in Excel VBA?
You do not need VBA to get the number of digits in a string, but here is one way to count them:
Public Function KountNumbers(r As Range) As Long
Dim i As Long, t As String
t = r.Text
For i = 1 To Len(t)
If Mid(t, i, 1) Like "[0-9]" Then KountNumbers = KountNumbers + 1
Next i
End Function
for example:
Without VBA try this:
=SUMPRODUCT(LEN(A1)-LEN(SUBSTITUTE(A1,{0,1,2,3,4,5,6,7,8,9},"")))
to get the number of numeric digits.
Your question is a little lacking in detail, but how about:
Sub test()
Debug.Print containsXnumbers("KT150", 3)
End Sub
Function containsXnumbers(sInput As String, xNumbers As Long) As Boolean
Dim x As Long
Dim numCount As Long
For x = 1 To Len(sInput)
If IsNumeric(Mid(sInput, x, 1)) Then numCount = numCount + 1
Next x
If numCount = xNumbers Then containsXnumbers = True
End Function
This should help:
Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Example:
Dim myStr as String
myStr = onlyDigits ("3d1fgd4g1dg5d9gdg")
MsgBox (myStr)
Will return (in a message box):
314159
*Code is exact copy of this SO answer
try with the below formula
Assume that your data are in A1. Apply the below formula in B1
=IF(AND(LEN(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A1,"1",""),"2",""),"3",""),"4",""),"5",""),"6",""),"7",""),"8",""),"9",""),"0",""))=2,LEN(A1)=5),"3 character numerals","No 3 numerals found")
Using VBA or A Standard formula, I need to edit the following from cells.
I need to remove everything up to and including "Path:",
Then I need it to find | and start over until it reaches the end of the Cell
Example:
Category Name: Ladies, Category Path: Ladies|Category Name: Sale, Category Path: Sale|Category Name: New, Category Path: New|
Goal:
Ladies|Sale|New
It can include NO "|" or it can include up to 20 "|"
Edit: Realized I needed to show my work AFTER the tour. :)
I have spent a day or two on this and so far this is only I can come up with...
Dim s As String
s = Range("Z7").Value
Dim indexOfPath As Integer
Dim indexOfPipe As Integer
Dim indexOfCat As Integer
indexOfPath = InStr(1, s, "Path:")
indexOfPipe = InStr(1, s, "|")
Dim finalString As String
Dim pipeString As String
finalString = Right(s, Len(s) - indexOfPath - 5)
indexOfCat = InStr(1, finalString, "Path:")
pipeString = Right(finalString, Len(finalString) - indexOfCat - 5)
Range("A47").Value = finalString
Range("A48").Value = pipeString
How ever I have got to the point where I am not confusing myself...
Split the cell value on "|", then split each value in the resulting array on "Path:" and take the second element from the result of that.
Like this:
Sub Tester()
Dim s As String, arr, v, arr2
s = "Category Name: Ladies, Category Path: Ladies|Category Name:" & _
" Sale, Category Path: Sale|Category Name: New, Category Path: New|"
arr = Split(s, "|")
For Each v In arr
v = Trim(v)
If Len(v) > 0 Then
arr2 = Split(v, "Path:")
If UBound(arr2) > 0 Then Debug.Print arr2(1)
End If
Next v
End Sub
Try this Function:
Function splitonbar(rng As Range) As String
Dim tempArr() As String
Dim temp As String
Dim i As Integer
tempArr = Split(rng.Value, "|")
For i = LBound(tempArr) To UBound(tempArr)
If Len(tempArr(i)) > 0 Then
temp = temp & "|" & Trim(Mid(tempArr(i), InStr(tempArr(i), "Path:") + 5))
End If
Next i
splitonbar = Mid(temp, 2)
End Function
It can be used as Formula on the sheet, or be called from another sub. To use as a UDF put in a module in the workbook then simply call it with a formula:
=splitonbar(Z7)
Or you can call it with a sub like this:
Sub splitstring()
Dim t as string
t = splitonbar(range("Z7"))
debug.print t
end sub
To directly fit your needs:
Public Function test(ByVal arg As Variant) As String
Dim i As Long
arg = Split(arg, "Category Name: ")
For i = 1 To UBound(arg)
arg(i) = Left(arg(i), InStr(arg(i), ",") - 1)
Next
test = Mid(Join(arg, "|"), 2)
End Function
The Split itself cuts everything in front of the keyword. The Left cuts everything after the comma (including the comma itself)
If you still have questons left, just ask :)
How is it possible to split a VBA string into an array of characters?
I tried Split(my_string, "") but this didn't work.
Safest & simplest is to just loop;
Dim buff() As String
ReDim buff(Len(my_string) - 1)
For i = 1 To Len(my_string)
buff(i - 1) = Mid$(my_string, i, 1)
Next
If your guaranteed to use ansi characters only you can;
Dim buff() As String
buff = Split(StrConv(my_string, vbUnicode), Chr$(0))
ReDim Preserve buff(UBound(buff) - 1)
You can just assign the string to a byte array (the reverse is also possible). The result is 2 numbers for each character, so Xmas converts to a byte array containing {88,0,109,0,97,0,115,0} or you can use StrConv
Dim bytes() as Byte
bytes = StrConv("Xmas", vbFromUnicode)
which will give you {88,109,97,115} but in that case you cannot assign the byte array back to a string. You can convert the numbers in the byte array back to characters using the Chr() function
Here's another way to do it in VBA.
Function ConvertToArray(ByVal value As String)
value = StrConv(value, vbUnicode)
ConvertToArray = Split(Left(value, Len(value) - 1), vbNullChar)
End Function
Sub example()
Dim originalString As String
originalString = "hi there"
Dim myArray() As String
myArray = ConvertToArray(originalString)
End Sub
According to this code golfing solution by Gaffi, the following works:
a = Split(StrConv(s, 64), Chr(0))
the problem is that there is no built in method (or at least none of us could find one) to do this in vb. However, there is one to split a string on the spaces, so I just rebuild the string and added in spaces....
Private Function characterArray(ByVal my_string As String) As String()
'create a temporary string to store a new string of the same characters with spaces
Dim tempString As String = ""
'cycle through the characters and rebuild my_string as a string with spaces
'and assign the result to tempString.
For Each c In my_string
tempString &= c & " "
Next
'return return tempString as a character array.
Return tempString.Split()
End Function
To split a string into an array of sub-strings of any desired length:
Function charSplitMulti(s As Variant, splitLen As Long) As Variant
Dim padding As Long: padding = 0
Dim l As Long: l = 0
Dim v As Variant
'Pad the string so it divides evenly by
' the length of the desired sub-strings
Do While Len(s) Mod splitLen > 0
s = s & "x"
padding = padding + 1
Loop
'Create an array with sufficient
' elements to hold all the sub-strings
Do Until Len(v) = (Len(s) / splitLen) - 1
v = v & ","
Loop
v = Split(v, ",")
'Populate the array by repeatedly
' adding in the first [splitLen]
' characters of the string, then
' removing them from the string
Do While Not s Like ""
v(l) = Mid(s, 1, splitLen)
s = Right(s, Len(s) - splitLen)
l = l + 1
Loop
'Remove any padding characters added at step one
v(UBound(v)) = Left(v(UBound(v)), Len(v(UBound(v))) - padding)
'Output the array
charSplitMulti = v
End Function
You can pass the string into it either as a string:
Sub test_charSplitMulti_stringInput()
Dim s As String: s = "123456789abc"
Dim subStrLen As Long: subStrLen = 4
Dim myArray As Variant
myArray = charSplitMulti(s, subStrLen)
For i = 0 To UBound(myArray)
MsgBox myArray(i)
Next
End Sub
…or already declard as a variant:
Sub test_charSplitMulti_variantInput()
Dim s As Variant: s = "123456789abc"
Dim subStrLen As Long: subStrLen = 5
s = charSplitMulti(s, subStrLen)
For i = 0 To UBound(s)
MsgBox s(i)
Next
End Sub
If the length of the desired sub-string doesn't divide equally into the length of the string, the uppermost element of the array will be shorter. (It'll be equal to strLength Mod subStrLength. Which is probably obvious.)
I found that most-often I use it to split a string into single characters, so I added another function, so I can be lazy and not have to pass two variables in that case:
Function charSplit(s As Variant) As Variant
charSplit = charSplitMulti(s, 1)
End Function
Sub test_charSplit()
Dim s As String: s = "123456789abc"
Dim myArray As Variant
myArray = charSplit(s)
For i = 0 To UBound(myArray)
MsgBox myArray(i)
Next
End Sub
Try this minicode From Rara:
Function charSplitMulti(TheString As Variant, SplitLen As Long) As Variant
'Defining a temporary array.
Dim TmpArray() As String
'Checking if the SplitLen is not less than one. if so the function returns the whole string without any changing.
SplitLen = IIf(SplitLen >= 1, SplitLen, Len(TheString))
'Redefining the temporary array as needed.
ReDim TmpArray(Len(TheString) \ SplitLen + IIf(Len(TheString) Mod SplitLen <> 0, 1, 0))
'Splitting the input string.
For i = 1 To UBound(TmpArray)
TmpArray(i) = Mid(TheString, (i - 1) * SplitLen + 1, SplitLen)
Next
'Outputing the result.
charSplitMulti = TmpArray
End Function