I built a macro that saves workbooks based on a list of names.
I'm getting a saveAs error because some of the new list items, have / which are not allowed in a file name.
I need some help in writing a code that will do this: note, that the list of teams, names, leagues and cups changes every row.
list item: team/ league
what I want: league
list item: team / league / cup
What I want: league-cup
List item; team / league / cup / score
what I want: league-cup-score
I have it working for the first scenario where there is only one / but can't figure out for rest.
InStr(Value, "/") > 0 Then
filename = Right(Value, (Len(Value) - InStr(Value, "/")))
Else
filename = Value
End If
is what I got so far.
Thanks
You could split, trim, and join:
Function MakeFileName(s As String) As String
Dim v As Variant, w As Variant
Dim i As Long, n As Long
v = Split(s, "/")
n = UBound(v)
ReDim w(1 To n)
For i = 1 To n
w(i) = Trim(v(i))
Next i
MakeFileName = Join(w, "-")
End Function
For example:
Sub test()
Debug.Print MakeFileName("team/ league")
Debug.Print MakeFileName("team / league / cup")
Debug.Print MakeFileName("team / league / cup / score")
End Sub
Output:
league
league-cup
league-cup-score
Yet another solution, this time using InStr. Edited to handle where no league is present.
Sub Example()
Dim str1 As String: str1 = "list item: team/ league"
Dim str2 As String: str2 = "list item: team / league / cup "
Dim str3 As String: str3 = "List item; team / league / cup / score"
Debug.Print getTeamText(str1)
Debug.Print getTeamText(str2)
Debug.Print getTeamText(str3)
End Sub
Function getTeamText(ByVal StringIn As String) As String
Dim strPos As Long
Dim lookFor As String: lookFor = "league"
strPos = InStr(1, LCase(StringIn), lookFor)
If strPos > 0 Then
getTeamText = Replace(Replace(Mid(StringIn, strPos, (Len(StringIn) - strPos) + 1), " ", ""), "/", "-")
Else
getTeamText = "Could not find match"
End If
End Function
Output should be as expected.
Using the code you already have, you can use the VBA replace function to replace "/" with "-"
filename = Replace(filename, "/", "-")
You need to use REPLACE
https://www.techonthenet.com/excel/formulas/replace_vba.php
example:
Dim oldString as String
Dim newString as String
newString=Replace(oldString,"/","_")
you could use
filename = Join(Split(Replace(Replace(Value, " ", ""), "team/", ""), "/"), "-")
Related
This has probably been asked a million times in different variations but I can't find an answer that fits.
I have a string that contains up to 4 MUT IDs ("MUT" followed by 5 numbers, eg MUT00761). If there is more than one ID, they are separated by a space. In some occasion, there will also be a * between two IDs (eg MUT00761 * MUT00684). The * is associated with the MUT ID on its left. I need to remove all those MUT IDs (and their *),if any.
EG, "MUT00111 MUT00222 * MUT00333 MUT00444 *" needs to become "MUT00111 MUT00333".
Worksheet Formula
=IFERROR(TRIM(SUBSTITUTE(A1,MID(A1,FIND("*",A1)-9,10),"")),A1)
VBA UDF
Function MUT(S as String) as String
On Error Resume Next
MUT = Trim(Replace(S, Mid(S, InStr(1, S, "*") - 9, 10), vbNullString))
If CBool(Err.Number) Then MUT = S
End Sub
1) get the position of 1st MUT with something instr(1,entireText, "MUT"[, …])
2) cut out MUT plus x characters or until the next "," with
3) do again until no MUT is found
Use the Microsoft VBScript Regular Expresions 5.5 library to replace instances of 'MUT *' with vbNullString.
OR
If you don;t grok Regex a simple function like
Public Function StripStarredIds(ByVal IdString As String) As String
Do While InStr(IdString, "*")
IdString = Replace(IdString, Mid$(IdString, InStr(IdString, "*") - 10, 10), vbNullString)
Loop
StripStarredIds = IdString
End Function
I would use a custom function to do this. It may be a bit clunky but this should work:
Function StripText(ByVal fullText As String) As String
newText = ""
lastIndex = 1
curIndex = InStr(1, fullText, " *")
If curIndex = 0 Then '// if no instances of " *" are found then just copy the full text
newText = fullText
Else
Do While (curIndex > 0) '// do until no instances of " *" are found
newText = newText & Mid(fullText, lastIndex, curIndex - lastIndex - 9)
lastIndex = curIndex + 2
curIndex = InStr(lastIndex + 1, fullText, " *")
Loop
End If
StripText = newText
End Function
you could use Split() function like this:
Function GiveItAName(s As String) As String
Dim res As String
Dim v As Variant, w As Variant
Dim i As Long, j As Long
v = Split(s, " *")
For j = 0 To UBound(v) - 1
w = Split(v(j), " ")
For i = 0 To UBound(w) - 1
res = res & w(i) & " "
Next
Next
GiveItAName = WorksheetFunction.Trim(res & v(j))
End Function
What I need to do is to basically write lessons number. There are 3 colomns.
The second column is running by a custom formula called LessonsLeft done by someone from my second thread on stackoverflow and it is
Function LessonsLeft(rng As Range) As String
If rng.Count > 1 Then Exit Function
Dim spltStr() As String
Dim i As Long
spltStr = Split(rng.Value, ",")
LessonsLeft = ",1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,"
For i = LBound(spltStr) To UBound(spltStr)
LessonsLeft = Replace(LessonsLeft, "," & spltStr(i) & ",", ",")
Next i
LessonsLeft = Mid(LessonsLeft, 2, Len(LessonsLeft) - 2)
End Function
What I need to do is to add another, third colomn which is for lessons that my students did their first attempt but they couldnt pass exam.
How i want the data to be there, is to write for exemple a "-" or "+" near a number in first column so the number will move to third column.
How can it be done ?
use this function
Function LessonsAttemptedButNotDone(rng As Range) As String
If rng.Count > 1 Then Exit Function
Dim spltStr() As String, lessonDone As String
Dim i As Long
spltStr = Split(rng.Value, ",")
For i = LBound(spltStr) To UBound(spltStr)
lessonDone = spltStr(i)
If Right(lessonDone, 1) = "-" Then
lessonDone = Left(lessonDone, Len(lessonDone) - 1)
LessonsAttemptedButNotDone = LessonsAttemptedButNotDone & lessonDone & ","
End If
Next
If LessonsAttemptedButNotDone <> "" Then LessonsAttemptedButNotDone = Left(LessonsAttemptedButNotDone, Len(LessonsAttemptedButNotDone) - 1)
End Function
I am working on a task where I have to copy/paste the content from website into excel.
But the problem is when I copy/paste the content in excel, it appears like this :
Los AngelesNew YorkSilicon Valley
Consumer InternetMobileB2BEnterprise SoftwareE-CommerceMarketplacesSocial
Let s call Los Angeles an item which is merged with another item New York and I want to separate these items so that information is readable like this:
Los Angeles, New York, Silicon Valley
Consumer Internet, Mobile, B2B, Enterprise Software, E-Commerce, Marketplaces, Social
When I noticed I actually realized that on website (due to some technical reason) I was unable to copy the comma between items and therefore every other item was merged with a capital letter with previous item.
Now please help me know is there an intelligent way to solve this problem because there are hundred of entries. What I see is this is how this problem can be solved:
Identify a capital letter which is not after a space and has small letter previous to it.
Insert a comma and space at that place and continue with the remaining string.
Please feel free to elaborate if this won't work and if there is an alternative solution. VBA code/ Excel Formula - anything that can help me automate it. Thanks.
With "B2B" it would be a bit tougher, but it works pretty well with the others:
Public Sub TestMe()
Debug.Print insert_a_space("Los AngelesNew YorkSilicon Valley")
Debug.Print insert_a_space("Consumer InternetMobileB2BEnterprise SoftwareE-CommerceMarketplacesSocial")
End Sub
Public Function insert_a_space(my_str As String)
Dim my_char As String
Dim l_counter As Long
Dim str_result As String
For l_counter = 1 To Len(my_str)
my_char = Mid(my_str, l_counter, 1)
If Asc(my_char) >= 65 And Asc(my_char) <= 90 Then
If l_counter > 1 Then
If Asc(Mid(my_str, (l_counter - 1), 1)) <> 32 And _
Asc(Mid(my_str, (l_counter - 1), 1)) <> 45 Then
str_result = str_result & ", "
End If
End If
End If
str_result = str_result & my_char
Next l_counter
insert_a_space = str_result
End Function
The logic is that you run TestMe. Or use as an Excel function insert_a_space and then give the string. The function looks for big letters (between 65 and 90 asc) and if there is no space or - before the big letter (asc 32) and (asc 45), it writes a comma with a space to the answer.
Edit:
Workaround SaaS and B2B
The idea is to introduce an escape symbol. Thus, whenever we see "\" we ignore it. This escape symbol is introduced through str_replace_me and should be explicitly written for which options it is.
Public Sub TestMe()
Dim str_1 As String
Dim str_2 As String
str_1 = "Los AngelesNew YorkSilicon Valley"
str_2 = "Consumer InternetMobileB2BEnterprise SoftwareE-CommerceMarketplacesSocialSaaS"
Debug.Print insert_a_space(str_replace_me(str_1))
Debug.Print insert_a_space(str_replace_me(str_2))
End Sub
Public Function str_replace_me(my_str As String) As String
str_replace_me = Replace(my_str, "SaaS", "Saa\S")
str_replace_me = Replace(str_replace_me, "B2B", "B2\B")
End Function
Public Function insert_a_space(my_str As String)
Dim my_char As String
Dim l_counter As Long
Dim str_result As String
For l_counter = 1 To Len(my_str)
my_char = Mid(my_str, l_counter, 1)
If Asc(my_char) >= 65 And Asc(my_char) <= 90 Then
If l_counter > 1 Then
If Asc(Mid(my_str, (l_counter - 1), 1)) <> 32 And _
Asc(Mid(my_str, (l_counter - 1), 1)) <> 45 And _
Asc(Mid(my_str, (l_counter - 1), 1)) <> 92 Then
str_result = str_result & ", "
End If
End If
End If
str_result = str_result & my_char
Next l_counter
str_result = Replace(str_result, "\", "")
insert_a_space = str_result
End Function
Please paste this code in VBA module.
Function AddSpaces(pValue As String) As String
Dim xOut As String
xOut = VBA.Left(pValue, 1)
For i = 2 To VBA.Len(pValue)
xAsc = VBA.Asc(VBA.Mid(pValue, i, 1))
If xAsc >= 65 And xAsc <= 90 Then
xOut = xOut & "," & " " & VBA.Mid(pValue, i, 1)
Else
xOut = xOut & VBA.Mid(pValue, i, 1)
End If
Next
AddSpaces = xOut
End Function
After that go to your spreadsheet and enter this formula =addspaces(A1)
Copy the formula to all the cells that you want to change.
You can copy the content from the website and paste the same into a notepad. Then copy the content from the notepad and paste it into the Excel.
Let's say I have the following string within a cell:
E. Stark, T. Lannister, A. Martell, P Baelish, B. Dondarrion, and J. Mormont. Increased levels of nudity across Westeros contributes to its sporadic seasonal climate. Nat. Proc. Aca. Sci. (2011) 3: 142-149.
And I want to extract only the title from this. The approach I am considering is to write a script that says "Pull text from this string, but only if it is more than 50 characters long." This way it only returns the title, and not stuff like " Stark, T" and " Martell, P". The code I have so far is:
Sub TitleTest()
Dim txt As String
Dim Output As String
Dim i As Integer
Dim rng As Range
Dim j As Integer
Dim k As Integer
j = 5
Set rng = Range("A" & j) 'text is in cell A5
txt = rng.Value 'txt is string
i = 1
While j <= 10 'there are five references between A5 and A10
k = InStr(i, txt, ".") - InStr(i, txt, ". ") + 1 'k is supposed to be the length of the string returned, but I can't differenciate one "." from the other.
Output = Mid(txt, InStr(i, txt, "."), k)
If Len(Output) < 100 Then
i = i + 1
ElseIf Len(Output) > 10 Then
Output = Mid(txt, InStr(i, txt, "."), InStr(i, txt, ". "))
Range("B5") = Output
j = j + 1
End If
Wend
End Sub
Of course, this would work well if it wasn't two "." I was trying to full information from. Is there a way to write the InStr function in such a way that it won't find the same character twice? Am I going about this in the wrong way?
Thanks in advance,
EDIT: Another approach that might work (if possible), is if I could have one character be " any lower case letter." and ".". Would even this be possible? I can't find any example of how this could be achieved...
Here you go, it works exactly as you wish. Judging from your code I am sure that you can adapt it for your needs quite quickly:
Option Explicit
Sub ExtractTextSub()
Debug.Print ExtractText("E. Stark, T. Lannister, A. Martell, P Baelish, B. Dondarrion, and J. Mormont. Increased levels of nudity across Westeros contributes to its sporadic seasonal climate. Nat. Proc. Aca. Sci. (2011) 3: 142-149.")
End Sub
Public Function ExtractText(str_text As String) As String
Dim arr As Variant
Dim l_counter As Long
arr = Split(str_text, ".")
For l_counter = LBound(arr) To UBound(arr)
If Len(arr(l_counter)) > 50 Then
ExtractText = arr(l_counter)
End If
Next l_counter
End Function
Edit: 5 votes in no time made me improve my code a bit :) This would return the longest string, without thinking of the 50 chars. Furthermore, on Error handlaer and a constant for the point. Plus adding a point to the end of the extract.
Option Explicit
Public Const STR_POINT = "."
Sub ExtractTextSub()
Debug.Print ExtractText("E. Stark, T. Lannister, A. Martell, P Baelish, B. Dondarrion, and J. Mormont. Increased levels of nudity across Westeros contributes to its sporadic seasonal climate. Nat. Proc. Aca. Sci. (2011) 3: 142-149.")
End Sub
Public Function ExtractText(str_text As String) As String
On Error GoTo ExtractText_Error
Dim arr As Variant
Dim l_counter As Long
Dim str_longest As String
arr = Split(str_text, STR_POINT)
For l_counter = LBound(arr) To UBound(arr)
If Len(arr(l_counter)) > Len(ExtractText) Then
ExtractText = arr(l_counter)
End If
Next l_counter
ExtractText = ExtractText & STR_POINT
On Error GoTo 0
Exit Function
ExtractText_Error:
MsgBox "Error " & Err.Number & Err.Description
End Function
I have a list of full names in a column like for example:
Dave M. Butterworth
Dave M. Butterworth,II
H.F. Light jr
H.F. Light ,jr.
H.F. Light sr
Halle plumerey
The names are in a column. The initials are not limited to these only.
I want to extract the last name using a generic function. Is it possible?
Consider the following UDF:
Public Function LastName(sIn As String) As String
Dim Ka As Long, t As String
ary = Split(sIn, " ")
Ka = UBound(ary)
t = ary(Ka)
If t = "jr" Or t = ",jr" Or t = "sr" Or t = ",jr." Then
Ka = Ka - 1
End If
t = ary(Ka)
If InStr(1, t, ",") = 0 Then
LastName = t
Exit Function
End If
bry = Split(t, ",")
LastName = bry(LBound(bry))
End Function
NOTE:
You will have to expand this line:
If t = "jr" Or t = ",jr" Or t = "sr" Or t = ",jr." Then
to include all other initial sets you wish to exclude.You will also have to update this code to handle other exceptions as you find them !
Remove punctuation, split to an array and walk backwards until you find a string that does not match a lookup of ignorable monikers like "ii/jr/sr/dr".
You could also add a check to eliminate tokens based on their length.
Function LastName(name As String) As String
Dim parts() As String, i As Long
parts = Split(Trim$(Replace$(Replace$(name, ",", ""), ".", "")), " ")
For i = UBound(parts) To 0 Step -1
Select Case UCase$(parts(i))
Case "", "JR", "SR", "DR", "I", "II"
Case Else:
LastName = parts(i)
Exit Function
End Select
Next
End Function