So I've been trying for hours to figure out how to display the length of word count in vb.
For example, if I type in a sentence in a rich textbox and I click a button, I want a form to show up listing the number of one-letter words, two-letter words, three-letter words and so on within that sentence. The number of words of specific length will be outputted in labels, of course.
I found this short code online for word count:
dim wordcount as integer
dim a as string() = RichText.Text.Split(" ")
wordcount = a.length
However, I'm not sure if this code can be used to get the length of word count. Any ideas of how I can achieve outputting the number of words of a specific length in a label? Thank you.
What about something like:
Private Sub mnuCount_Click()
Const DELIMITERS As String = vbNewLine & " !"",.:;?"
Dim WordCounts(1 To 100) As Long
Dim Msg As String
Dim I As Integer
Dim WordCount As Long
With RTB
.Visible = False
.SelStart = 0
Do
.UpTo DELIMITERS, vNegate:=True
.Span DELIMITERS, vNegate:=True
If .SelLength > 0 Then
WordCounts(.SelLength) = WordCounts(.SelLength) + 1
.SelStart = .SelStart + .SelLength
Else
Exit Do
End If
Loop
.SelStart = 0
.Visible = True
End With
Msg = "Length" & vbTab & "Count"
For I = 1 To 100
If WordCounts(I) > 0 Then
Msg = Msg & vbNewLine _
& CStr(I) & vbTab & CStr(WordCounts(I))
WordCount = WordCount + WordCounts(I)
End If
Next
Msg = Msg & vbNewLine _
& "Grand total:" & vbNewLine _
& vbTab & CStr(WordCount)
MsgBox Msg
End Sub
Pradnya's code, translated to VB6:
Option Explicit
Private Sub Command1_Click()
Dim str As String
Dim splitStr() As String
Dim i As Integer
str = "ABC DEF GHIJ KLMNOPQ"
splitStr = Split(str, " ")
MsgBox "Number of words = " & UBound(splitStr) + 1 & vbCrLf & _
"Average Length = " & Len(Replace(str, " ", "")) / (UBound(splitStr) + 1)
End Sub
I made a few simplifications as well. There's no need to go through the loop to get the average. All you have to do to get the length of the whole is remove the spaces and divide by the number of elements in the array.
However, if you want to get a count of the number of words of each length, you'll have to loop through the array, getting the length of each word and storing those values one by one. Best way to do that is to set a reference to scrrun.dll (Windows Scripting Runtime) and use a Dictionary object to store the values.
Related
Okay, I am trying to convert the user given decimal number to binary but Internet Explorer gives me this error:
Isn't that how you send a dynamic array as function argument in VBScript?
VBScript code:
Function toBinary(number, binary)
Dim remainder : remainder = 0
Dim index : index = 0
While (number <> 0)
remainder = number Mod 2
number = number \ 2
ReDim binary(index)
binary(index) = remainder
index = index + 1
Wend
toBinary = binary
End Function
Dim number
Dim response : response = vbYes
Dim binary()
While (response = vbYes)
number = InputBox("Enter A Decimal Number: ")
If (Not IsNumeric(number)) Then
response = MsgBox("Wrong Input, Wanna Try Again? ", vbYesNo)
Else
MsgBox (number & " is equal to " & toBinary(number, binary) & " in Binary")
response = vbNo
End If
Wend
In the line msgbox ( number & " is equal to " & toBinary(number, binary) & " in Binary"), the function toBinary(...) returns an array.
An array cannot be converted to a string in vbscript, so when you concatenate it to display it, you get an error.
In your example, I would suggest that you build a string instead of an array and return that string :
Function toBinary(value)
dim result : result = ""
dim remainder : remainder = 0
If value = 0 Then
result = "0"
Else
While (value <> 0)
remainder = value Mod 2
result = remainder & result
value = value \ 2
Wend
End If
toBinary = result
End Function
dim number
dim response : response = vbYes
dim binary()
while ( response = vbYes )
number = inputbox("Enter A Decimal Number: ")
if ( Not IsNumeric(number)) then
response = msgbox("Wrong Input, Wanna Try Again ? ", vbYesNo)
else
msgbox ( number & " is equal to " & toBinary(number) & " in Binary")
response = vbNo
end if
wend
Below code works great as expected the only downside is its slow because I am using this to search for all the instances of the substring and delete the Entire row if found in any cell of the whole workbook.
Aim is simple just delete the entirerow if the entered string is found in any cell string
Dim wo As Worksheet, ws As Worksheet
Dim I As Long, j As Long, m As Long
Dim toFind As String, testStr As String
Dim pos As Long
Dim lstRow As Long, cutRow As Long
Dim WS_Count As Integer
Dim Cell As Range
Option Compare Text
Option Explicit
Sub SearchDelete()
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
j = 0
If toFind = "" Then
MsgBox "Empty String Entered.Exiting Sub Now."
Exit Sub
Else
WS_Count = ActiveWorkbook.Worksheets.Count
'Begin the loop.
For I = 1 To WS_Count
Label1:
For Each Cell In Worksheets(I).UsedRange.Cells
If Trim(Cell.Text) <> "" Then
pos = 0
pos = InStr(1, Trim(Cell.Text), toFind, vbTextCompare)
If pos > 0 Then 'match Found'
cutRow = Cell.Row
Worksheets(I).Rows(cutRow).EntireRow.Delete
j = j + 1
GoTo Label1
Else: End If
Else: End If
Next Cell
Next I
End If
MsgBox "Total " & j & " Rows were deleted!"
End Sub
Individual operations are pretty much always slower than bulk operations and the Range.Delete method is no exception. Collecting the matching rows with a Union method and then performing the removal en masse will significantly speed up the operation.
Temporarily suspending certain application environment handlers will also help things along. You do not need Application.ScreenUpdating active while you are removing rows; only after you have completed the operation.
Option Explicit
Option Compare Text
Sub searchDelete()
Dim n As Long, w As Long
Dim toFind As String, addr As String
Dim fnd As Range, rng As Range
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
If Not CBool(Len(toFind)) Then
MsgBox "Empty String Entered.Exiting Sub Now."
GoTo bm_Safe_Exit
End If
'appTGGL bTGGL:=False 'uncomment this line when you have finsihed debugging
With ActiveWorkbook
For w = 1 To .Worksheets.Count
With .Worksheets(w)
Set fnd = .Cells.Find(what:=toFind, lookat:=xlPart, _
after:=.Cells.SpecialCells(xlCellTypeLastCell))
If Not fnd Is Nothing Then
Set rng = .Rows(fnd.Row)
n = n + 1
addr = fnd.Address
Do
If Intersect(fnd, rng) Is Nothing Then
n = n + 1
Set rng = Union(rng, .Rows(fnd.Row))
End If
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address
Debug.Print rng.Address(0, 0)
rng.Rows.EntireRow.Delete
End If
End With
Next w
End With
Debug.Print "Total " & n & " rows were deleted!"
bm_Safe_Exit:
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Debug.Print Timer
End Sub
The answer to your question: "How to speed up this code to find and delete rows if a substring is found" is - DON'T repeat the search from the top of the sheet after you found and removed the row!
I do PowerShell not VBScript, so I am a little lost. I am trying to list all mapped drives (drive letter and share path) in a MsgBox. I get a type mismatch error when running the script. If I change "Dim myArray()" to "Dim myArray" I get only one item from the variable.
Set objNetwork = WScript.CreateObject("WScript.Network")
Set colDrives = objNetwork.EnumNetworkDrives
Dim myArray()
For i = 0 to colDrives.Count-1 Step 2
myArray = colDrives.Item(i) & vbTab & colDrives.Item (i + 1)
Next
MsgBox(myArray)
How can I get the data saved to an array, then output to a MsgBox?
The reason why your code doesn't work is because you're creating fixed-size array without an actual size (Dim myArray()), and then try to assign values to that array. In VBScript you must assign values to array positions (myArray(pos) = val), and you cannot append to the built-in arrays (at least not without some additional work).
The most straightforward approach in your case would be the method #Bond suggested. However, you can do this with arrays if you want. You just need a resizable array like this:
ReDim myArray(-1) 'empty array
For i = 0 to colDrives.Count-1 Step 2
ReDim Preserve myArray(UBound(myArray)+1)
myArray(UBound(myArray)) = colDrives.Item(i) & vbTab & colDrives.Item(i+1)
Next
MsgBox Join(myArray, vbNewLine)
or (using an ArrayList), like this:
Set myArray = CreateObject("System.Collections.ArrayList")
For i = 0 to colDrives.Count-1 Step 2
myArray.Add colDrives.Item(i) & vbTab & colDrives.Item(i+1)
Next
MsgBox Join(myArray.ToArray, vbNewLine)
Since the size of the array can already be determined before entering the loop you could also dimension the array with the proper size right away to avoid repeated redimensioning (which tends to perform poorly for VBScript built-in arrays):
ReDim myArray(colDrives.Count \ 2 - 1)
For i = 0 to colDrives.Count-1 Step 2
myArray(i\2) = colDrives.Item(i) & vbTab & colDrives.Item(i+1)
Next
MsgBox Join(myArray, vbNewLine)
Another option would be using a Dictionary:
Set myArray = CreateObject("Scripting.Dictionary")
For i = 0 to colDrives.Count-1 Step 2
myArray(colDrives.Item(i)) = colDrives.Item(i) & vbTab & colDrives.Item(i+1)
Next
MsgBox Join(myArray.Items, vbNewLine)
You can use a string and keep appending (&) to it.
Dim s
For i = 0 To colDrives.Count-1 Step 2
s = s & colDrives.Item(i) & vbTab & colDrives.Item (i + 1) & vbCrLf
Next
MsgBox s
want to know the count of occurrence one word in the text box in Visual BASIC v.0.6 ?
i tried to use the counter from the list but it was not good
for example: in the following sentence:
" go to play and go to home"... the verb "go" appear 2 times ..then.. i want the code that count the number of occurrence of verb "go" and say to me through label for example: 2 times
for example: in the following sentence:
" go to play and go to home"... the verb "go" appear 2 times ..then.. i want the code that count the number of occurrence of verb "go" and say to me through label for example: 2 times
You can use replace() to remove the word from the string, and then compare the length resulting string with the length of the original string, and devide that by the length of the word
Option Explicit
Private Sub Command1_Click()
Label1.Caption = CStr(CountWord(Text1.Text, "go")) & " times"
End Sub
Private Sub Form_Load()
Text1.Text = " go to play and go to home"
End Sub
Private Function CountWord(strText As String, strWord As String) As Long
CountWord = (Len(strText) - Len(Replace(strText, strWord, ""))) / Len(strWord)
End Function
the function CountWord above finds the amount of strWord in strText, it doesn't search for separate words, but also adds one to the count if strWord is part of a larger word
For example " go to play and go to home to search on google" would count 3 instances of "go"
Try the following code: -
Dim txt$, find$, i1%, count%
txt = "go to play and go to home"
find = "go"
i1 = 0
Do
i1 = InStr(i1 + 1, txt, find)
If i1 > 0 Then
count = count + 1
i1 = i1 + Len(find)
Else
Exit Do
End If
Loop
MsgBox count
You can use regular expressions to count word occurrences
Private Sub Form_Load()
Debug.Print CountWords(" go to play and G.O to home to search on g.o" & vbCrLf & "ogle", "g.o")
End Sub
Private Function CountWords(sText As String, sWord As String) As Long
Dim sPattern As String
sPattern = pvInitRegExp("[-[\]{}()*+?.,\\^$|#\s]").Replace(sWord, "\$&")
CountWords = pvInitRegExp("\s" & sPattern & "\s").Execute(sText).Count
End Function
Private Function pvInitRegExp(sPattern As String) As Object
Set pvInitRegExp = CreateObject("VBScript.RegExp")
With pvInitRegExp
.Pattern = sPattern
.Global = True
.IgnoreCase = True
.MultiLine = True
End With
End Function
This takes care of word boundaries too so "google" is not counted.
I'm trying to see if I can programatically trap an AutoFilter sort event, get the sort criteria and then apply that same sort criteria to an AutoFilter in a second worksheet.
So far it seems as though I have to trigger the Worksheet_Calculate() event. And this I've done. Then I have to check if the AutoFilter sort criteria was changed. If it wasn't, exit sub. If it was, collect the criteria and run it through a separate sub, which does the exact same sorting on an AutoFilter in a separate worksheet.
The general idea is that whenever one of these two AutoFilters are sorted, the AutoFilter in the other sheet should be sorted the exact same way.
I've tried to do something like this (I had to add an Excel formula to actually make the calculate event trigger):
Private Sub Worksheet_Calculate()
Dim wbBook as Workbook
Dim wsSheet as Worksheet
Dim rnData as Range
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
With wsSheet
Set dnData = .UsedRange
End With
End Sub
But I can't seem to manage to collect the criteria, I've tried several things and adding a watch to the dnData doesn't even reveal any AutoFilter property. Can someone shed any light on this?
Here is a way to get the autofilter criteria:
Sub test()
Dim Header As Range
Dim sMainCrit As String, sANDCrit As String, sORCrit As String
Set Header = Range("A2:C2")
With Header.Parent.AutoFilter
With .Filters(Header.Column - .Range.Column + 1)
If Not .On Then
MsgBox ("no criteria")
Exit Sub
End If
sMainCrit = .Criteria1
If .Operator = xlAnd Then
sANDCrit = .Criteria2
ElseIf .Operator = xlOr Then
sORCrit = .Criteria2
End If
End With
End With
MsgBox ("Main criteria: " & sMainCrit & Chr(13) & "AND Criteria:" & sANDCrit & Chr(13) & "OR Criteria" & sORCrit)
End Sub
Adapted from ozgrid
Here are some notes on what I see as your requirements.
Dim rv As AutoFilter ''Object
Set rv = Sheet1.AutoFilter
''Just for curiosity
Debug.Print rv.Sort.Header
Debug.Print rv.Sort.SortFields.Count
Debug.Print rv.Sort.SortFields.Item(1).SortOn
Debug.Print rv.Sort.Rng.Address
Debug.Print rv.Sort.SortFields.Item(1).Key.Address
''One key only, but it is easy enough to loop and add others
Sheet2.Range(rv.Sort.Rng.Address).Sort _
key1:=Sheet2.Columns(rv.Sort.SortFields(1).Key.Column), _
Header:=xlYes
Found this code:
Sub ShowAutoFilterCriteria()
' John Green et. al: Excel 2000 VBA Programmer?s Reference, S. 379f
' 09.01.2005
Dim oAF As AutoFilter
Dim oFlt As Filter
Dim sField As String
Dim sCrit1 As String
Dim sCrit2 As String
Dim sMsg As String
Dim i As Integer
' Check if the sheet is filtered at all
If ActiveSheet.AutoFilterMode = False Then
MsgBox "The sheet does not have an Autofilter"
Exit Sub
End If
' Get the sheet?s Autofilter object
Set oAF = ActiveSheet.AutoFilter
' Loop through the Filters of the Autofilter
For i = 1 To oAF.Filters.Count
' Get the field name form the first row
' of the Autofilter range
sField = oAF.Range.Cells(1, i).Value
' Get the Filter object
Set oFlt = oAF.Filters(i)
' If it is on...
If oFlt.On Then
' Get the standard filter criteria
sMsg = sMsg & vbCrLf & sField & oFlt.Criteria1
' If it?s a special filter, show it
Select Case oFlt.Operator
Case xlAnd
sMsg = sMsg & " And " & sField & oFlt.Criteria2
Case xlOr
sMsg = sMsg & " Or " & sField & oFlt.Criteria2
Case xlBottom10Items
sMsg = sMsg & " (bottom 10 items)"
Case xlBottom10Percent
sMsg = sMsg & " (bottom 10%)"
Case xlTop10Items
sMsg = sMsg & " (top 10 items)"
Case xlTop10Percent
sMsg = sMsg & " (top 10%)"
End Select
End If
Next i
If msg = "" Then
' No filters are applied, so say so
sMsg = "The range " & oAF.Range.Address & " is not filtered."
Else
' Filters are applied, so show them
sMsg = "The range " & oAF.Range.Address & " is filtered by:" & sMsg
End If
' Display the message
MsgBox sMsg
End Sub
Works fine on my tests! I've changed a small part of it to support complex criteria:
' Get the standard filter criteria
If IsArray(oFlt.Criteria1) Then
Dim x As Integer
sMsg = sMsg & vbCrLf & sField
For x = 1 To UBound(oFlt.Criteria1)
sMsg = sMsg & "'" & oFlt.Criteria1(x) & "'"
Next x
Else
sMsg = sMsg & vbCrLf & sField & "'" & oFlt.Criteria1 & "'"
End If
Original link: http://www.vbaexpress.com/forum/archive/index.php/t-7564.html