i have string like "NIFTY29-12-2016CE6300.00"
and i want output as :
"NIFTY_29-12-2016_6300_CE"
the problem is first part i.e.(NIFTY) is not fixed in length it can be abcd,rdftghe or anything
And last part i.e.(6300.00) is also not fixed length it can be 123.8888888.23.88989 or anything
try this code to get position of the first digit in a string and i able to concat "_" before that the code is as follow :
If InStr(CStr(rs.Fields!Symbol), "CE") Then
StrOg = CStr(rs.Fields!Symbol)
For i = 1 To Len(StrOg)
currentCharacter = Mid(StrOg, i, 1)
If IsNumeric(currentCharacter) = True Then
GetPosChar = i
Exit For
End If
Next i
strtemp = Left(StrOg, GetPosChar) & "_" & Right() & "_"
Else
i'm acheving till this :"NIFTY_"
please help me!!!! thanks in advance
Try below. Since you have not given proper explanation of where changes has to be made. I wrote the code with some assumptions like, symbol CE is available to you, we need to truncate all decimal part, etc. You can see teh code and proceed further.
Private Sub test()
Dim StrOg As String
StrOg = "NIFTY29-12-2016CE6123.8888888"
Debug.Print "Org=" & StrOg
Debug.Print "New=" & ReFormat(StrOg)
End Sub
Private Function ReFormat(ByVal inputText) As String
Dim strNew As String
Dim charPos As Integer
Dim counter As Integer
Dim found As Boolean
'Search for 1st character from reverse and remove the 2 charters (i.e. symbol CE)
found = False
For i = Len(inputText) To 1 Step -1
If (Not IsNumeric(Mid$(inputText, i, 1))) And Mid$(inputText, i, 1) <> "." Then
charPos = i
found = True
Exit For
End If
Next i
If found Then
strNew = Left$(inputText, charPos - 2) & "_" & Right$(inputText, Len(inputText) - charPos)
Else
strNew = inputText
End If
'Search for 1st digit and if found update the string
found = False
For i = 1 To Len(strNew)
If IsNumeric(Mid$(strNew, i, 1)) Then
charPos = i
found = True
Exit For
End If
Next i
If found Then
strNew = Left$(strNew, charPos - 1) & "_" & Right$(strNew, Len(strNew) - charPos + 1)
End If
'Search for last decimal and truncate thereAfter
charPos = InStrRev(strNew, ".")
If charPos > 0 Then
strNew = Left$(strNew, charPos - 1) & "_CE"
End If
ReFormat = strNew
End Function
Related
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 am fairly new in VBA, i am working on a project, there's small problem i am facing. I am taking newLastCmtTypeCol, newLastCmtCol, newLastNoteCol, oldLastCmtTypeCol, oldLastCmtCol, oldLastNoteCol as strings and i am only calling them in this part of code. so the error happend when one of the string start with a special character. I am taking input from sheet with alot of data. there's absolutely no way i can go through all of that data all the time. I just wanna ignore the strings start with starts with special character, so i wouldnt see any error.Here is the part of the code.
Dim newLastCmtTypeCol As String
Dim newLastCmtCol As String
Dim newLastNoteCol As String
Dim oldLastCmtTypeCol As String
Dim oldLastCmtCol As String
Dim oldLastNoteCol As String
newLastCmtTypeCol = "N"
newLastCmtCol = "O"
newLastNoteCol = "P"
oldLastCmtTypeCol = "Q"
oldLastCmtCol = "R"
oldLastNoteCol = "S"
For j = 0 To indexNew(i, 4)
If (StrComp(ws1.Range(newLastCmtTypeCol & i + j), ws1.Range(oldLastCmtTypeCol & i + j)) = 0) And _
(StrComp(ws1.Range(newLastCmtCol & i + j), ws1.Range(oldLastCmtCol & i + j)) = 0) And _
(StrComp(ws1.Range(newLastNoteCol & i + j), ws1.Range(oldLastNoteCol & i + j)) = 0) And categoryCode = 1 Then
categoryCode = 1
ElseIf IsEmpty(ws1.Range(oldLastCmtTypeCol & i + j)) And IsEmpty(ws1.Range(oldLastCmtCol & i + j)) And IsEmpty(ws1.Range(oldLastNoteCol & i + j)) Then
categoryCode = 3
Exit For
Else
categoryCode = 2
End If
Next j
Any solution?
Your issues seems to be with cells containing an error, not special characters.
If so, you probably want to filter out such cells.
You could use IsError to wrap your code, e.g.
If (Not (IsError(ws1.Range(newLastCmtTypeCol & i + j))) and _
Not (IsError(ws1.Range(oldLastCmtTypeCol & i + j))) and _
... _
) Then
Then you would be able to compare anything else.
You may want to use conversions between String and numbers, if needed.
Public Function DelInvalidCharacters(InputString As String) As String
Dim ModString As String, InvalidChars As String, Char As String
Dim i As Integer
InvalidChars = "\/:*?""<>|';#,()%&$+- "
ModString = vbNullString
For i = 1 To Len(InputString)
Char = Mid(InputString, i, 1)
If InStr(1, InvalidChars, Char) = 0 Then
ModString = ModString & Char
End If
Next i
DelInvalidCharacters = ModString
End Function
Just call this function for each variable you want to strip bad characters out of
Calling it like this
Dim this As String
this = "*this"
this = DelInvalidCharacters(this)
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 am searching for a solution to convert a double to a string, but the string should have a comma before the decimal place, not a point.
"One and a half" should look that way 1,5 (german notation).
Thanks for your help!!
A combination of CStr and Replace will do the job.
Function Dbl2Str(dbl As Double) As String
Dbl2Str = Replace(CStr(dbl), ".", ",")
End Function
Unfortunately in VBA, you can't easily write locale-independent code. That is, you can't specify a locale when you take a CStr cast.
One work around is to convert a double like 0.5 to a string and see what you end up with. If you end up with 0,5 then you're in German (etc.) locale, and you don't need to do anything else.
If you end up with 0.5 then you know you need to make a conversion. Then you just need to traverse your string, replacing dots with commas and vice versa (the vice versa bit is important in case your string has thousands delimiters). You can use Replace for that.
Following RubberDuck comment I ended up with this:
Function DblToStr(x As Double)
DblToStr = CStr(x)
If (Application.ThousandsSeparator = ".") Then
DblToStr = Replace(DblToStr, ".", "")
End If
If (Application.DecimalSeparator = ".") Then
DblToStr = Replace(DblToStr, ".", ",")
End If
End Function
something like this then
Dim somestring As String
Dim someDec As Double
someDec = 1.5
somestring = CStr(someDec)
somestring = Replace(somestring, ".", ",")
MsgBox (somestring)
Select the cells you wish to convert and run this small macro:
Sub changeIT()
For Each r In Selection
t = r.Text
If InStr(1, r, ".") > 0 Then
r.Clear
r.NumberFormat = "#"
r.Value = Replace(t, ".", ",")
End If
Next r
End Sub
Only those cells with "." in them will change and they will be Strings rather than Doubles
I checked the other answers but ended up writing my own solution to convert user inputs like 1500.5 into 1,500.50, using below code:
'
' Separates real-numbers by "," and adds "." before decimals
'
Function FormatNumber(ByVal v As Double) As String
Dim s$, pos&
Dim r$, i&
' Find decimal point
s = CStr(v)
pos = InStrRev(s, ".")
If pos <= 0 Then
pos = InStrRev(s, ",")
If pos > 0 Then
Mid$(s, pos, 1) = "."
Else
pos = Len(s) + 1
End If
End If
' Separate numbers into "r"
On Error Resume Next
i = pos - 3
r = Mid$(s, i, 3)
For i = i - 3 To 1 Step -3
r = Mid$(s, i, 3) & "," & r
Next i
If i < 1 Then
r = Mid$(s, 1, 2 + i) & "," & r
End If
' Store dot and decimal numbers into "s"
s = Mid$(s, pos)
i = Len(s)
If i = 2 Then
s = s & "0"
ElseIf i <= 0 Then
s = ".00"
End If
' Append decimals and return
FormatNumber = r & s
End Function
I am getting the impression that this is not possible in word but I figure if you are looking for any 3-4 words that come in the same sequence anywhere in a very long paper I could find duplicates of the same phrases.
I copy and pasted a lot of documentation from past papers and was hoping to find a simple way to find any repeated information in this 40+ page document there is a lot of different formatting but I would be willing to temporarily get rid of formatting in order to find repeated information.
To highlight all duplicate sentences, you can also use ActiveDocument.Sentences(i). Here is an example
LOGIC
1) Get all the sentences from the word document in an array
2) Sort the array
3) Extract Duplicates
4) Highlight duplicates
CODE
Option Explicit
Sub Sample()
Dim MyArray() As String
Dim n As Long, i As Long
Dim Col As New Collection
Dim itm
n = 0
'~~> Get all the sentences from the word document in an array
For i = 1 To ActiveDocument.Sentences.Count
n = n + 1
ReDim Preserve MyArray(n)
MyArray(n) = Trim(ActiveDocument.Sentences(i).Text)
Next
'~~> Sort the array
SortArray MyArray, 0, UBound(MyArray)
'~~> Extract Duplicates
For i = 1 To UBound(MyArray)
If i = UBound(MyArray) Then Exit For
If InStr(1, MyArray(i + 1), MyArray(i), vbTextCompare) Then
On Error Resume Next
Col.Add MyArray(i), """" & MyArray(i) & """"
On Error GoTo 0
End If
Next i
'~~> Highlight duplicates
For Each itm In Col
Selection.Find.ClearFormatting
Selection.HomeKey wdStory, wdMove
Selection.Find.Execute itm
Do Until Selection.Find.Found = False
Selection.Range.HighlightColorIndex = wdPink
Selection.Find.Execute
Loop
Next
End Sub
'~~> Sort the array
Public Sub SortArray(vArray As Variant, i As Long, j As Long)
Dim tmp As Variant, tmpSwap As Variant
Dim ii As Long, jj As Long
ii = i: jj = j: tmp = vArray((i + j) \ 2)
While (ii <= jj)
While (vArray(ii) < tmp And ii < j)
ii = ii + 1
Wend
While (tmp < vArray(jj) And jj > i)
jj = jj - 1
Wend
If (ii <= jj) Then
tmpSwap = vArray(ii)
vArray(ii) = vArray(jj): vArray(jj) = tmpSwap
ii = ii + 1: jj = jj - 1
End If
Wend
If (i < jj) Then SortArray vArray, i, jj
If (ii < j) Then SortArray vArray, ii, j
End Sub
SNAPSHOTS
BEFORE
AFTER
I did not use my own DAWG suggestion, and I am still interested in seeing if someone else has a way to do this, but I was able to come up with this:
Option Explicit
Sub test()
Dim ABC As Scripting.Dictionary
Dim v As Range
Dim n As Integer
n = 5
Set ABC = FindRepeatingWordChains(n, ActiveDocument)
' This is a dictionary of word ranges (not the same as an Excel range) that contains the listing of each word chain/phrase of length n (5 from the above example).
' Loop through this collection to make your selections/highlights/whatever you want to do.
If Not ABC Is Nothing Then
For Each v In ABC
v.Font.Color = wdColorRed
Next v
End If
End Sub
' This is where the real code begins.
Function FindRepeatingWordChains(ChainLenth As Integer, DocToCheck As Document) As Scripting.Dictionary
Dim DictWords As New Scripting.Dictionary, DictMatches As New Scripting.Dictionary
Dim sChain As String
Dim CurWord As Range
Dim MatchCount As Integer
Dim i As Integer
MatchCount = 0
For Each CurWord In DocToCheck.Words
' Make sure there are enough remaining words in our document to handle a chain of the length specified.
If Not CurWord.Next(wdWord, ChainLenth - 1) Is Nothing Then
' Check for non-printing characters in the first/last word of the chain.
' This code will read a vbCr, etc. as a word, which is probably not desired.
' However, this check does not exclude these 'words' inside the chain, but it can be modified.
If CurWord <> vbCr And CurWord <> vbNewLine And CurWord <> vbCrLf And CurWord <> vbLf And CurWord <> vbTab And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbCr And CurWord.Next(wdWord, ChainLenth - 1) <> vbNewLine And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbCrLf And CurWord.Next(wdWord, ChainLenth - 1) <> vbLf And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbTab Then
sChain = CurWord
For i = 1 To ChainLenth - 1
' Add each word from the current word through the next ChainLength # of words to a temporary string.
sChain = sChain & " " & CurWord.Next(wdWord, i)
Next i
' If we already have our temporary string stored in the dictionary, then we have a match, assign the word range to the returned dictionary.
' If not, then add it to the dictionary and increment our index.
If DictWords.Exists(sChain) Then
MatchCount = MatchCount + 1
DictMatches.Add DocToCheck.Range(CurWord.Start, CurWord.Next(wdWord, ChainLenth - 1).End), MatchCount
Else
DictWords.Add sChain, sChain
End If
End If
End If
Next CurWord
' If we found any matching results, then return that list, otherwise return nothing (to be caught by the calling function).
If DictMatches.Count > 0 Then
Set FindRepeatingWordChains = DictMatches
Else
Set FindRepeatingWordChains = Nothing
End If
End Function
I have tested this on a 258 page document (TheStory.txt) from this source, and it ran in just a few minutes.
See the test() sub for usage.
You will need to reference the Microsoft Scripting Runtime to use the Scripting.Dictionary objects. If that is undesirable, small modifications can be made to use Collections instead, but I prefer the Dictionary as it has the useful .Exists() method.
I chose a rather lame theory, but it seems to work (at least if I got the question right cuz sometimes I'm a slow understander).
I load the entire text into a string, load the individual words into an array, loop through the array and concatenate the string, containing each time three consecutive words.
Because the results are already included in 3 word groups, 4 word groups or more will automatically be recognized.
Option Explicit
Sub Find_Duplicates()
On Error GoTo errHandler
Dim pSingleLine As Paragraph
Dim sLine As String
Dim sFull_Text As String
Dim vArray_Full_Text As Variant
Dim sSearch_3 As String
Dim lSize_Array As Long
Dim lCnt As Long
Dim lCnt_Occurence As Long
'Create a string from the entire text
For Each pSingleLine In ActiveDocument.Paragraphs
sLine = pSingleLine.Range.Text
sFull_Text = sFull_Text & sLine
Next pSingleLine
'Load the text into an array
vArray_Full_Text = sFull_Text
vArray_Full_Text = Split(sFull_Text, " ")
lSize_Array = UBound(vArray_Full_Text)
For lCnt = 1 To lSize_Array - 1
lCnt_Occurence = 0
sSearch_3 = Trim(fRemove_Punctuation(vArray_Full_Text(lCnt - 1) & _
" " & vArray_Full_Text(lCnt) & _
" " & vArray_Full_Text(lCnt + 1)))
With Selection.Find
.Text = sSearch_3
.Forward = True
.Replacement.Text = ""
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
Do While .Execute
lCnt_Occurence = lCnt_Occurence + 1
If lCnt_Occurence > 1 Then
Selection.Range.Font.Color = vbRed
End If
Selection.MoveRight
Loop
End With
Application.StatusBar = lCnt & "/" & lSize_Array
Next lCnt
errHandler:
Stop
End Sub
Public Function fRemove_Punctuation(sString As String) As String
Dim vArray(0 To 8) As String
Dim lCnt As Long
vArray(0) = "."
vArray(1) = ","
vArray(2) = ","
vArray(3) = "?"
vArray(4) = "!"
vArray(5) = ";"
vArray(6) = ":"
vArray(7) = "("
vArray(8) = ")"
For lCnt = 0 To UBound(vArray)
If Left(sString, 1) = vArray(lCnt) Then
sString = Right(sString, Len(sString) - 1)
ElseIf Right(sString, 1) = vArray(lCnt) Then
sString = Left(sString, Len(sString) - 1)
End If
Next lCnt
fRemove_Punctuation = sString
End Function
The code assumes a continuous text without bullet points.