It's delete all listbox items text after question mark.
But I want to opposite. So, replace my listbox items text before question mark.
Example listbox item text:
somethingpage?Iwantit
My code:
For i = cbox1.Items.Count - 1 To 0 Step -1
For x = cbox1.Items.Count - 1 To 0 Step -1
If cbox1.Items(i).ToString.Contains("?") Then
Dim item = cbox1.Items(i).ToString()
Dim pos = item.IndexOf("?")
item = item.Substring(0, pos)
cbox1.Items(i) = item
End If
Next
Here's a version that uses Regex to fix your issue...
Private lstObject As New List(Of Object) 'To hold your values
Dim oObject As Object
'Go through changing what we need to and then adding to our list
For i As Integer = 0 To ListBox1.Items.Count - 1
oObject = Regex.Replace(CStr(ListBox1.Items(i)), "^(.*?)\?", "", RegexOptions.IgnorePatternWhitespace)
lstObject.Add(oObject)
Next
'If we have items, add them back to the list
If lstObject.Count > 0 Then
ListBox1.Items.Clear()
For i As Integer = 0 To lstObject.Count - 1
ListBox1.Items.Add(lstObject.Item(i).ToString)
Next
End If
For i As Integer = 0 to cbox1.Items.Count - 1
Dim sItem As String = cbox1.Items(i).ToString()
If sItem.Contains("?") Then
cbox1.Items(i) = sItem.Remove(0, sItem.IndexOf("?"))
End If
Next
Okay so here's a way to get this done without errors:
Dim FormattedString() As String
For i = cbox1.Items.Count - 1 To 0 Step -1
If cbox1.Items(i).ToString.Contains("?") Then
Dim item = cbox1.Items(i).ToString()
FormattedString = Split(item, "?", 2)
cbox1.Items(i) = FormattedString(0)
End If
Next
Related
Here is my code:
Dim list As New List(Of String)
'populate list with string values
Dim list2 As New List(Of String())
For i As Integer = 0 To list.Count - 1
list2.Add({list.Item(i), "temp"})
Next
for x as integer = 0 to list.count
Dim test1 = list2.indexof({list.item(x), "temp"}) '***this line is returning -1
next
Although I can clearly see that list2 contains in its first index the strings:
"Garry" and "temp"
it refuses to return an index other than -1 when I search for an index containing:
{"Garry", "temp"}
Just ended up restructuring my code as to avoid the problem -- all good now.
I am not sure as to why this wasn't working; if anybody comes looking for a solution.
Please see the following code:
Sub CountAndHighlightProblematicCells()
Dim RegExpo As New RegExp
Dim strPattern As String: strPattern = "[^\u0020-\u007E]"
Dim specialCharactersFound As Object
Dim strInput As String
Dim counter As Long
RegExpo.Global = True
RegExpo.MultiLine = True
RegExpo.IgnoreCase = False
RegExpo.Pattern = strPattern
counter = 0
For Each cell In Worksheets(1).Range("A1:A100")
strInput = Worksheets(1).Range(cell.Address).Value
If (RegExpo.Test(strInput)) Then
Worksheets(1).Range(cell.Address).Interior.ColorIndex = 20
counter = counter + 1
End If
Set specialCharactersFound = RegExpo.Execute(strInput)
Next
MsgBox ("Number of affected cells: " & counter)
MsgBox ("Number of special characters found: " & specialCharactersFound.Count)
End Sub
For some reason, the test operation works as expected, but the execute operation does not.
If you think that it has something to do with the for loop, I checked and it does not - the execute operation does not work as expected even when The focus in on one cell only.
What am I doing wrong? I'm not very experienced with VBA generally and RegExp
specifically.
Thanks in advance,
Kurkum
I suggest adding these 2 lines to variable declarations:
Dim specialCharactersFound As New Collection
Dim mtch As Object
and then, instead of the code between counter = 0 and Next, use
counter = 0
Set specialCharactersFound = New Collection ' Initialize the collection for special chars
For Each cell In Worksheets(1).Range("A1:A100")
strInput = Worksheets(1).Range(cell.Address).Value
Set mtch = RegExpo.Execute(strInput) ' Find the matches
For Each objMatch In mtch ' Iterate throug the match collection
specialCharactersFound.Add (mtch(0).Value) ' Add the char found to the collection
Next
Worksheets(1).Range(cell.Address).Interior.ColorIndex = 20
counter = counter + 1 ' Increment the affected cell count
Next
Spent a week trying to figure this out, so far, so I'm not just jumping here first - and all Microsoft sites tend to focus on Excel which seems to be non-appropriate for what I'm doing:
I'm attempting to use this VBA script to open up multiple WORD files, in succession, run a Find/Selection to grab a specific pattern, and then copy all occurrences into another WORD file.
This code is a mix of something I found online (though can't recall where, at this point) and my own tinkering. I've been able to DEBUG.PRINT the correct output, but no way to continue to move through my file to copy specific lines and then paste them. I feel it has something to do with the .Activate calls:
Sub x()
Dim GetStr(5000) As String
Const wdStory = 4
Const wdExtend = 1
'Set Doc = Documents.Open(FileName:="C:\Users\...\filename.CDS", Visible:=True)
'Set Doc = Documents.Open("C:\Users\...\filename.CDS")
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.CDS", 1
.AllowMultiSelect = True
i = 2 'set to 2 in order to offset the open word window that houses the VBA
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open ("C:\Users\...\filename.docx")
For j = 2 To i Step 1
Set objDoc = objWord.Documents.Open(GetStr(j))
'Debug.Print (objWord.Documents(1).Name)
Set objSelection = objWord.Selection
objSelection.Find.Forward = True
objSelection.Find.MatchWildcards = True
objSelection.Find.Text = "DEFINE"
Do While True
objSelection.Find.Execute
Debug.Print (objSelection)
If objSelection.Find.Found Then
objSelection.EndOf wdStory, wdExtend 'get selection
strText = objSelection.Copy 'strText = selection copied to clipboard, no value (like an inline function)
Set selectionToPaste = objWord.Selection 'selectionToPaste is literally the clipboard
'objWord.Documents(2).Activate
'Debug.Print ("->'Activated Window': " + objWord.ActiveDocument.Name)
'Debug.Print ("selectionToPaste = " + selectionToPaste)
selectionToPaste.Paste
'objWord.Documents(1).Activate
objSelection.Find.Execute
Else
objWord.ActiveDocument.Save
objWord.ActiveWindow.Close
Exit Do
End If
Loop
Next
End With
End Sub
OP here - Solved my own problem utilizing a loop.
Sub x()
Dim GetStr(5000) As String
**Dim iCounter As Integer**
Const wdStory = 4
Const wdExtend = 1
'Set Doc = Documents.Open(FileName:="C:\Users\...\filename.CDS", Visible:=True)
'Set Doc = Documents.Open("C:\Users\...\filename.CDS")
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.CDS", 1
.AllowMultiSelect = True
i = 2 'set to 2 in order to offset the open word window that houses the VBA
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open ("C:\Users\lidm3b2\Desktop\gar\2.docx")
For j = 2 To i Step 1
Set objDoc = objWord.Documents.Open(GetStr(j))
'Debug.Print (objWord.Documents(1).Name)
Set objSelection = objWord.Selection
objSelection.Find.Forward = True
objSelection.Find.MatchWildcards = True
objSelection.Find.Text = "DEFINE"
**iCounter = 0**
Do While True
**For iLoopCounter = 0 To iCounter Step 1
objSelection.Find.Execute
Next**
Debug.Print (objSelection)
If objSelection.Find.Found Then
objSelection.EndOf wdStory, wdExtend 'get selection
strText = objSelection.Copy 'strText = selection copied to clipboard, no value (like an inline function)
Set selectionToPaste = objWord.Selection 'selectionToPaste is literally the clipboard
objWord.Documents(2).Activate
'Debug.Print ("->'Activated Window': " + objWord.ActiveDocument.Name)
'Debug.Print ("selectionToPaste = " + selectionToPaste)
objWord.Selection.Paste
objWord.Documents(1).Activate
**iLoopCounter = iLoopCounter + 1**
objSelection.Find.Execute
Else
objWord.ActiveDocument.Save
objWord.ActiveWindow.Close 'have to close for the hardcode on "...Documents(1)..." and 2 to work.
Exit Do
End If
Loop
Next
End With
End Sub
I can't seem to figure out the RegExp to extract the bullet points between two group of words in a word document.
For example:
Risk Assessment:
Test 1
Test 2
Test 3
Internal Audit
In this case I want to extract the bullet points between "Risk Assessment" and "Internal Audit", one bullet at a time and assign that bullet to an Excel cell. As shown in the code below I have pretty much everything done, except I cant figure out the correct Regex pattern. Any help would be great. Thanks in advance!
Sub PopulateExcelTable()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file."
.Filters.Clear
.Filters.Add "Word 2007-2013", "*.docx"
If .Show = True Then
txtFileName = .SelectedItems(1)
End If
End With
Dim WordApp As Word.Application
Set WordApp = CreateObject("Word.Application")
Dim WordDoc As Word.Document
Set WordDoc = WordApp.Documents.Open(txtFileName)
Dim str As String: str = WordDoc.Content.Text ' Assign entire document content to string
Dim rex As New RegExp
rex.Pattern = "\b[^Risk Assessment\s].*[^Internal Audit\s]"
Dim i As long : i = 1
rex.Global = True
For Each mtch In rex.Execute(str)
Debug.Print mtch
Range("A" & i).Value = mtch
i = i + 1
Next mtch
WordDoc.Close
WordApp.Quit
End Sub
This is probably a long way around the problem but it works.
Steps I'm taking:
Find bullet list items using keywords before and after list in regexp.
(Group) regexp pattern so that you can extract everything in-between words.
Store listed items group into a string.
Split string by new line character into a new array.
Output each array item to excel.
Loop again since there may be more than one list in document.
Note: I don't see your code for a link to Excel workbook. I'll assume this part is working.
Dim rex As New RegExp
rex.Pattern = "(\bRisk Assessment\s)(.*)(Internal\sAudit\s)"
rex.Global = True
rex.MultiLine = True
rex.IgnoreCase = True
Dim lineArray() As String
Dim myMatches As Object
Set myMatches = rex.Execute(str)
For Each mtch In rex.Execute(str)
'Debug.Print mtch.SubMatches(1)
lineArray = Split(mtch.SubMatches(1), vbLf)
For x = LBound(lineArray) To UBound(lineArray)
'Debug.Print lineArray(x)
Range("A" & i).Value = lineArray(x)
i = i + 1
Next
Next mtch
My test page looks like this:
Results from inner Debug.Print line return this:
Item 1
Item 2
Item 3
I want to be able to copy raw data into column A, hit run on the macro and it should remove any unwanted characters both before and after the data that I want to keep resulting in a cell just containing the data that I want. I also want it to go through all cells that are in the column, bearing in mind some cells may be empty.
The data that I want to keep is in this format: somedata0000 or somedata000
Sometimes the cell will contain 'rubbish' both before and after the data that I want to keep i.e. rubbishsomedata0000 or somedata0000rubbish or rubbishsomedata0000rubbish.
And also, sometimes a single cell will contain:
rubbishsomedata0000rubbish
rubbishsomedata0000rubbish
rubbishsomedata0000rubbish
This will need to be changed to:
NEW CELL: somedata0000
NEW CELL: somedata0000
NEW CELL: somedata0000
The 'somedata' text will not change but the 0000 (which could be any 4 numbers) will sometimes be any 3 numbers.
Also there may be some rows in the column that have no useful data; these should be removed/deleted from the sheet.
Finally, some cells will contain the perfect somedata0000, these should stay the same.
Sub Test()
Dim c As Range
For Each c In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
c = removeData(c.text)
Next
End Sub
Function removeData(ByVal txt As String) As String
Dim result As String
Dim allMatches As Object
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = "(somedata-\d{4}|\d{3})"
RE.Global = True
RE.IgnoreCase = True
Set allMatches = RE.Execute(text)
If allMatches.Count <> 0 Then
result = allMatches.Item(0).submatches.Item(0)
End If
ExtractSDI = result
End Function
I have put my code that I've got so far, all it does is go through each cell, if it matches it just removes the text that I want to keep as well as the stuff that I want removed! Why?
There are several issues in your code
As Gary said, you Function isn't returning a result
Your Regex.Pattern doesn't make sense
Your Sub doesn't attempt to handle multiple matches
Your Function doesn't even attempt to return multiple matches
Sub Test()
Dim rng As Range
Dim result As Variant
Dim i As Long
With ActiveSheet
Set rng = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
For i = rng.Rows.Count To 1 Step -1
result = removeData(rng.Cells(i, 1))
If IsArray(result) Then
If UBound(result) = 1 Then
rng.Cells(i, 1) = result(1)
Else
rng.Cells(i, 1).Offset(1, 0).Resize(UBound(result) - 1, 1).Insert xlShiftDown
rng.Cells(i, 1).Resize(UBound(result), 1) = Application.Transpose(result)
End If
Else
rng.Cells(i, 1).ClearContents
End If
Next
End Sub
Function removeData(ByVal txt As String) As Variant
Dim result As Variant
Dim allMatches As Object
Dim RE As Object
Dim i As Long
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = "(somedata\d{3,4})"
RE.Global = True
RE.IgnoreCase = True
Set allMatches = RE.Execute(txt)
If allMatches.Count > 0 Then
ReDim result(1 To allMatches.Count)
For i = 0 To allMatches.Count - 1
result(i + 1) = allMatches.Item(i).Value
Next
End If
removeData = result
End Function