Current code:
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim Gold = CInt(TextBox1.Text)
Dim Silver = CInt(TextBox2.Text) / 100
Dim Copper = CInt(TextBox3.Text) / 10000
Dim Result = (Gold + Silver + Copper) * 0.85
Label1.Text = Result & " Gold"
End Sub
and
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
If (TextBox1.Text + TextBox2.Text + TextBox3.Text = "") Then
Button1.Enabled = False
Else
Button1.Enabled = True
End If
End Sub
How come whenever I start the program, and I enter numbers into textbox1, textbox2, and textbox3 the button does not get enabled?
You need to add TextChanged handlers to TextBox1,TextBox2,TextBox3. If text any of them changes, then you need to do you check from Form1_Load:
If (TextBox1.Text + TextBox2.Text + TextBox3.Text = "") Then
Button1.Enabled = False
Else
Button1.Enabled = True
End If
Ideally, write a private method to do the above code, and just call it from each of the TextBox handlers. Just a good practice.
Because Form1_Load() is executed only once before you even entered the numbers.
Related
I have tried to convert one of my Visual Basic 6 programs to Visual Basic.NET. This program basically crawls email and mobile number data from a web page link. This program works great in Visual Basic 6 but after converting to Visual Basic.NET is not providing any function or result in .NET.
Imports VBScript_RegExp_55
Imports System.Collections.Specialized
Imports System.Diagnostics
Public Class autoextratorform
Dim emailsearch As New ListViewItem()
Dim numbersearch As New ListViewItem
Private Declare Function SendMessageByString _
Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) _
As Long
Private Const LB_SELECTSTRING = &H18C
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private WithEvents cIE As InternetHtml
Private WithEvents cExtLinks As cExtractLinks
Private cGSearch As cGoogleSearch
Dim Excel As Object
Dim Excelsheet As Object
Dim a() As String
Dim b() As String
Dim c() As String
Dim i As Integer
' Needs reference to Microsoft VBscript Regular Expressions I recomend ver 5.5.
'
Dim baseurl As String ' var to store base url so we can build the full path
Dim dVisited ' Dictionary to hold visited urls = I think Missing here
Dim dEmail ' dictionary to hold emails = I think Missing here
Dim dnumber ' = I think Missing here
Dim dweb '= I think Missing here
' We are putting the emails in a list also, for user feed back
'It would be less momery intensive and faster to just keep these in the dictionry object
'which allows to easily tell if the email already exist
Dim regxPage ' var to hold regular expression to extract urls
Dim regxEmail ' var to hold regular expression to extract emails
Dim regnumber
Dim regweb
Dim Match, Matches As String ' we use these to store are regx matches
Dim Match1, Matches1 As String
Dim Match2, Matches2 As String
' Regular expressions are super powerfull and have been a part of unix for a long time
' goto the form load event to see the regex initialization
' to learn more about regular expressions and to download the latest scripting runtime see
' http://msdn.microsoft.com/scripting/default.htm?/scripting/vbscript/techinfo/vbsdocs.htm
Dim email, pageurl, mnumber, sweb As String
' The above is only because dictionary.exist does not work directly on Match var
Dim stopcrawl As Integer ' Used to exit crawl loop
Private Sub ComboBox1_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ComboBox1.SelectedIndexChanged
Select Case ComboBox1.SelectedIndex
Case 0
ListBox2.Items.Clear()
ListBox2.Items.Add("http://classads.jang.com.pk/default.asp?cityid=1")
ListBox2.Items.Add("http://www.merapakistan.com/classifieds/")
ListBox2.Items.Add("http://olx.com.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
Case 1
ListBox2.Items.Clear()
ListBox2.Items.Add("http://www.locanto.com.pk/")
ListBox2.Items.Add("http://pakistanclassifiedads.com/")
ListBox2.Items.Add("http://pkr.com.pk/")
txtStartUrl.Text = ListBox2.Text
Case 2
ListBox2.Items.Clear()
ListBox2.Items.Add("http://adpost.pk/")
ListBox2.Items.Add("http://page.com.pk/")
ListBox2.Items.Add("http://www.clasf.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
Case 3
ListBox2.Items.Clear()
ListBox2.Items.Add("http://www.nelaam.com/")
ListBox2.Items.Add("http://www.asani.com.pk/")
ListBox2.Items.Add("http://freepost.com.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
End Select
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Command1.Click
stopcrawl = 0 ' set stop crawl so we do not exit loop
If txtStartUrl.Text & "" = "" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
ElseIf txtStartUrl.Text & "" = "http://" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
ElseIf txtStartUrl.Text = "" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
End If
' the above should really check for a valid url, but I am a lazy PERL programmer
ListBox1.Items.Add(txtStartUrl.Text) 'add item to list
Label16.Text = (ListBox2.Items.Count - 1)
Label8.Text = (ListBox2.Items.Count)
lblresult.Text = " Start service for searching Email address and Mobile Numbers"
Command1.Enabled = False
ComboBox1.Enabled = False
LaVolpeButton4.Enabled = True
'UPGRADE_ISSUE: (2064) ComboBox property Combo1.Locked was not upgraded. More Information: https://docs.mobilize.net/vbuc/ewis#2064
LaVolpeButton8.Enabled = False
LaVolpeButton9.Enabled = False
txtStartUrl.ReadOnly = True
crawl() ' and were off
End Sub
Private Sub autoextrator_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
With listnumber
.Columns.Clear()
.Columns.Add("Count!", CInt(Width * 0.1))
.Columns.Add("Mobile Number!", CInt(Width * 0.2))
.Columns.Add("Web URL!", CInt(Width * 0.68))
End With
With listemail
.Columns.Clear()
.Columns.Add("Count!", CInt(Width * 0.1))
.Columns.Add("Email Address!", CInt(Width * 0.2))
.Columns.Add("Web URL!", CInt(Width * 0.68))
End With
'initialize dictionary and regx objects
dVisited = CreateObject("Scripting.Dictionary")
dVisited.CompareMode = CompareMethod.Binary
dEmail = CreateObject("Scripting.Dictionary")
dEmail.CompareMode = CompareMethod.Binary
dnumber = CreateObject("Scripting.Dictionary")
dnumber.CompareMode = CompareMethod.Binary
dweb = CreateObject("Scripting.Dictionary")
dweb.CompareMode = CompareMethod.Binary
Dim counting1 As String
Dim counting2 As String
regxPage = New VBScript_RegExp_55.RegExp() ' Create a regular expression.
regxPage.Pattern = "HREF=""[^""#]+[.][^""#]+" ' Set pattern."
regxPage.IgnoreCase = True ' Set case insensitivity.
regxPage.Global = True ' Set global applicability.
regxEmail = New VBScript_RegExp_55.RegExp() ' Create a regular expression.
regxEmail.Pattern = "\b[a-z0-9._%+-]+#[a-z0-9.-]+\.[a-z]{2,4}\b" ' Set pattern."
regxEmail.IgnoreCase = True ' Set case insensitivity.
regxEmail.Global = True ' Set global applicability.
regnumber = New VBScript_RegExp_55.RegExp()
counting1 = "(\+92)-?\d{3}-?\d{7}"
counting2 = "(?:0092|0|\+92)-?\d{3}-?\d{7}"
regnumber.Pattern = counting1
regnumber.Pattern = counting2
regnumber.IgnoreCase = True
regnumber.Global = True
cIE = New InternetHtml()
cGSearch = New cGoogleSearch()
cExtLinks = New cExtractLinks()
End Sub
Sub crawl()
While ListBox1.Items.Count > 0 ' loop while list has data
If stopcrawl = 1 Then GoTo exitcrawl
getpage(ListBox1.Items(0)) ' This is the heart of the prog, except for the regx = I think Missing here
' stuff in the form load event
ListBox1.Items.Remove(0) ' remove item from list
End While
ListBox2.Items.Remove(ListBox2.SelectedIndex)
If ListBox2.SelectedIndex < ListBox2.Items.Count - 1 Then
ListBox2.SelectedIndex += 1
txtStartUrl.Text = ListBox2.Items.ToString
exitcrawl:
If ListBox2.Items.Count = 0 Then
MessageBox.Show("Searching has completed !", "Done ! searching", MessageBoxButtons.OK, MessageBoxIcon.Information)
txtStartUrl.ReadOnly = False
txtStartUrl.Text = ""
Label3.Text = "-----------------------------------------------------------"
LaVolpeButton4.Enabled = False
Command1.Enabled = True
LaVolpeButton8.Enabled = True
LaVolpeButton9.Enabled = True
End If
End If
End Sub
Sub getpage(ByVal page As String)
On Error Resume Next
If dVisited.Contains(page) Then
Exit Sub
Else
dVisited.Add(page, 1) ' add page to dVisited dictionary
Label6.Text = CStr(ListBox1.Items.Count)
Label14.Text = CStr(dVisited.Count)
Label3.Text = page
End If
baseurl = getpath(page) ' build full url - see getpath
TextBox1.Text = ""
If ListBox1.Items.Count > 5000 Then Exit Sub ' sets the maximum cache (so we don't run out of mem)
Using wc As New System.Net.WebClient
TextBox1.Text = wc.DownloadString(page)
End Using
Matches = regxPage.Execute(TextBox1.Text) ' Execute search.
For Each Me.Match In Matches
pageurl = Match
If InStr(1, pageurl, "http://", vbTextCompare) Then
If dVisited.Exists(pageurl) = False Then ListBox1.Items.Add(Mid(pageurl, 7))
Else
If dVisited.Exists(baseurl & Mid(pageurl, 7)) = False Then ListBox1.Items.Add(baseurl & Mid(pageurl, 7))
End If
Next
' search for email
Matches = regxEmail.Execute(TextBox1.Text) ' Execute search.
For Each Me.Match In Matches ' Iterate Matches collection.
' check if email exist
email = Match
Debug.Print(email & dEmail.Exists(email))
If dEmail.Exists(email) = False Then
dEmail.Add((email), 1)
Dim d As Integer
d = listemail.Items.Count
d = d + 1
emailsearch = listemail.Items.Add(d)
emailsearch.SubItems.Add(email.ToString)
emailsearch.SubItems.Add(pageurl.ToString)
ListBox3.Items.Add(email)
Label10.Text = listemail.Items.Count
End If
Next
Matches1 = regnumber.Execute(TextBox1.Text)
For Each Me.Match1 In Matches1
mnumber = Match1
Debug.Print(mnumber & dnumber.Exists(mnumber))
If dnumber.Exists(mnumber) = False Then
dnumber.Add((mnumber), 1)
Dim c As Integer
c = listnumber.Items.Count
c = c + 1
numbersearch = listnumber.Items.Add(c)
numbersearch.SubItems.Add(mnumber.ToString)
numbersearch.SubItems.Add(pageurl.ToString)
Label12.Text = listnumber.Items.Count
End If
Next
End Sub
Function getpath(ByVal URL As String) As String
' look for the last / and get a string up to that location
Dim lastbar As Integer = URL.LastIndexOf("/") + 1
Dim tmppath As String = URL.Substring(0, Math.Min(lastbar, URL.Length))
If tmppath = "http://" Then tmppath = URL ' full path already so return url
Return tmppath
End Function
Public Function StripOut(ByVal From As String, ByVal What As String) As String
Dim result As String = ""
result = From
For i As Integer = 1 To Strings.Len(What)
result = result.Replace(What.Substring(i - 1, Math.Min(1, What.Length - (i - 1))), "")
Next i
Return result
End Function
Private Sub LaVolpeButton4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles LaVolpeButton4.Click
stopcrawl = 1
MsgBox(" Service has Stoped by USER !")
LaVolpeButton4.Enabled = False
Command1.Enabled = True
End Sub
Private Sub LaVolpeButton8_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles LaVolpeButton8.Click
Dim strData As String = ""
Dim strQ() As String
Dim intFile As Integer
' Set up the Common Dialog initial Directory
' to the application path. Filter for Text and All files
' Prompt the user to select a file
'
cmd.InitialDirectory = My.Application.Info.DirectoryPath
cmd.Filter = "Text Files(*.txt)|*.txt|All Files(*.*)|*.*"
cmd.Title = "Select Email Addresses File"
cmd.ShowDialog()
If cmd.FileName <> "" Then
'
' If the user selected a file
' open and read the entire contents
' then split it into records
'
intFile = FileSystem.FreeFile()
FileSystem.FileOpen(intFile, cmd.FileName, OpenMode.Input)
strData = FileSystem.InputString(intFile, FileSystem.LOF(intFile))
FileSystem.FileClose(intFile)
strQ = strData.Split(CChar(Environment.NewLine))
'
' Populate the texbox array with the questions
' (either the number of textboxes in the control array or
' number of questions, which ever is the smaller)
For Each strQ_item As String In strQ
ListBox2.Items.Add(strQ_item)
Next strQ_item
txtStartUrl.Text = ListBox2.Text
End If
End Sub
End Class
2- This is Visual basic 6 Code that works perfect.
Dim baseurl As String ' var to store base url so we can build the full path
Dim dVisited As Dictionary ' Dictionary to hold visited urls
Dim dEmail As Dictionary ' dictionary to hold emails
Dim dnumber As Dictionary
Dim dweb As Dictionary
Sub crawl()
While List1.ListCount > 0 ' loop while list has data
If stopcrawl = 1 Then GoTo exitcrawl
getpage List1.List(0) ' This is the heart of the prog, except for the regx
' stuff in the form load event
List1.RemoveItem (0) ' remove item from list
Wend
List2.RemoveItem (List2.ListIndex)
If List2.ListIndex < List2.ListCount - 1 Then
List2.ListIndex = List2.ListIndex + 1
txtStartUrl = List2.Text
Command1_Click
Else
exitcrawl:
If List2.ListCount = 0 Then
MsgBox "Searching has completed !", vbInformation, "Done ! searching"
WebBrowser1.Stop
txtStartUrl.Locked = False
txtStartUrl.Text = ""
Label3.Caption = "-----------------------------------------------------------"
LaVolpeButton4.Enabled = False
Command1.Enabled = True
LaVolpeButton8.Enabled = True
LaVolpeButton9.Enabled = True
End If
End If
End Sub
I am trying to search a string without regex perhaps a bad idea !
The search is acting on a string of text in a RichText Box
If I search for "is" the first word in the String is "This"
The last two letters of "This" is are highlighted in vbRed
The string to be searched has two other occurrences of "is" and these are found and highlighted as expected
The question can I prevent the "is" in "This" from being found?
Private Sub btnSearch_Click()
Dim pos As Integer
Dim strToFind As String
Dim Y As Integer
Dim Ask As String
pos = 1
strToFind = tbSearch.Text
Do
strToFind = tbSearch.Text
pos = InStr(1, strToSearch, strToFind)
For Y = 1 To Len(strToSearch)
Ask = MsgBox("Yes Next Occurrence or No To Exit ?", vbYesNo, "Question")
If Ask = vbYes Then
lbOne.AddItem pos
tbAns.Text = pos
If pos = 0 Then
Exit Sub
End If
rtbOne.SelStart = pos - 1
rtbOne.SelLength = Len(strToFind)
rtbOne.SelColor = vbRed
pos = InStr(pos + 1, strToSearch, strToFind)
Else
tbAns.Text = "NO"
pos = InStr(pos + 1, strToSearch, strToFind)
tbAns.Text = pos
Exit Sub
End If
Next
Loop Until pos > 0
End Sub
Private Sub Form_Load()
strToSearch = "This is a lot of text that will be loaded in the lbText and we will search it is it a case sensative Search"
rtbOne.Text = strToSearch
tbSearch.Text = "is"
End Sub
If this is not possible a few suggestions on how to use regex
I know this much I need to add the Reference and this might be the
Pattern myRegExp.Pattern = "(.)\strToFind\b(.)"
TOM FindText accepts the tomMatchWord flag. Just use that. Don't screw aroung extracting text out of the control and then munching on it using slow scripting language crutches like RegEx.
I was intrigued by the idea of a "built-in" search, as suggested by Bob77 and Mark, so I put together code to implement this idea. The code uses a WinAPI call but is really pretty simple overall and supports moving forward and backward along with toggles for case sensitivity and whole words:
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_USER = &H400&
Private Const EM_GETOLEINTERFACE = (WM_USER + 60)
Private Enum Direction
Forward = 1
Backward = -1
End Enum
Private Doc As ITextDocument
Private Sub Form_Load()
RichTextBox1.HideSelection = False
RichTextBox1.Text = "is This is a lot of text that will be loaded in the lbText and we will " & _
"search it is it a case sensative Search" & vbCr & vbCr & _
"is and IS and is"
SearchTerm.Text = "is"
Dim Unknown As IUnknown
SendMessage RichTextBox1.hwnd, EM_GETOLEINTERFACE, 0&, Unknown
Set Doc = Unknown
End Sub
Private Sub cmdForward_Click()
Match SearchTerm.Text, chkWhole.Value, chkCase.Value, Forward
End Sub
Private Sub cmdBack_Click()
Match SearchTerm.Text, chkWhole.Value, chkCase.Value, Backward
End Sub
Private Sub Match(ByVal SearchTerm As String, ByVal WholeWords As Integer, ByVal CaseSensitive As Integer, ByVal Direction As Direction)
Dim Flags As Long
Flags = 2 * WholeWords + 4 * CaseSensitive
Doc.Selection.FindText SearchTerm, Direction * Doc.Selection.StoryLength, Flags
End Sub
You will need to add a reference to RICHED20.dll using the "Browse..." button in Project|References.
You might find following InStrAll implementation based on VBScript.RegExp useful.
Option Explicit
Private Sub Form_Load()
Const STR_TEXT As String = "This is a lot of text that will be loaded in the lbText and we will search it is it a case sensative Search"
Dim vElem As Variant
For Each vElem In InStrAll(STR_TEXT, "is")
Debug.Print vElem, Mid$(STR_TEXT, vElem, 2)
Next
End Sub
Public Function InStrAll(sText As String, sSearch As String, Optional ByVal Compare As VbCompareMethod = vbTextCompare) As Variant
Dim lIdx As Long
Dim vRetVal As Variant
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = (Compare <> vbBinaryCompare)
.Pattern = "[.*+?^${}()/|[\]\\]"
.Pattern = "\b" & .Replace(sSearch, "\$&") & "\b"
With .Execute(sText)
If .Count = 0 Then
vRetVal = Array()
ElseIf .Count = 1 Then
vRetVal = Array(.Item(0).FirstIndex + 1)
Else
ReDim vRetVal(0 To .Count - 1) As Variant
For lIdx = 0 To .Count - 1
vRetVal(lIdx) = .Item(lIdx).FirstIndex + 1
Next
End If
End With
End With
InStrAll = vRetVal
End Function
The point is first you have to escape the searched string (prefix all regex control symbols with backslash) and then wrap this escaped pattern with \bs before performing the "global" search for all matches.
The InStrAll function returns an array of indexes in the original text. It's up to your to impl actual color-coded highlighting in the RichTextBox control of your choice. (I would set the background color, not the foreground of the found snippet, if I had a choice. Notice how most browsers use yellow background for search results highlighting.)
For a non-Regex approach, try the following:
Option Explicit
Private Sub Form_Load()
RichTextBox1.Text = "is This is a lot of text that will be loaded in the lbText and we will " & _
"search it is it a case sensative Search" & vbCr & vbCr & _
"is and is and is"
End Sub
Private Sub Command1_Click()
Dim SearchTerm As String
Dim SearchIndex As Integer
SearchTerm = "is"
SearchIndex = 1
Do
SearchIndex = InStr(SearchIndex, RichTextBox1.Text, SearchTerm)
If isMatch(SearchIndex, SearchTerm) Then
RichTextBox1.SelStart = SearchIndex - 1
RichTextBox1.SelLength = Len(SearchTerm)
RichTextBox1.SelColor = vbRed
End If
If SearchIndex > 0 Then SearchIndex = SearchIndex + Len(SearchTerm)
Loop Until SearchIndex = 0
End Sub
Private Function isMatch(ByVal SearchIndex As Long, ByVal SearchTerm As String) As Boolean
If SearchIndex = 1 Then
If Mid(RichTextBox1.Text, SearchIndex + Len(SearchTerm), 1) = " " Then isMatch = True
ElseIf SearchIndex + Len(SearchTerm) >= Len(RichTextBox1.Text) Then
If Mid(RichTextBox1.Text, SearchIndex - 1, 1) = " " Then isMatch = True
ElseIf SearchIndex > 1 Then
If (Mid(RichTextBox1.Text, SearchIndex - 1, 1) = " " Or Mid(RichTextBox1.Text, SearchIndex - 1, 1) = vbCr) And Mid(RichTextBox1.Text, SearchIndex + Len(SearchTerm), 1) = " " Then isMatch = True
End If
End Function
As noted in the comments, the original code had limitations. The code now supports matches at the beginning and end of the text, along with embedded breaks. You will likely need to add more checks to the isMatch method.
I am struggling with a huge Excel sheet (with 200K rows), where I need to extract from a certain column (B) list of all email addresses present in the string.
What I want to achieve:
Extract the email from string
convert (at) to # and (dot) to .
Save name and email in separate columns
Example of column B:
Shubhomoy Biswas <biswas_shubhomoy777(at)yahoo(dot)com>
Puneet Arora <ar.puneetarora(at)gmail(dot)com>
Anand Upadhyay <001.anand(at)gmail(dot)com>
Rajat Gupta <rajatgupta0889(at)gmail(dot)com>
Sarvesh Sonawane <sarvesh.s(at)suruninfocoresystems.
Although I want to be able to do it on Excel any other Windows-based utility suggestion would be helpful.
this can be done assuming they are all in the same format and only 1 email add per cell
=SUBSTITUTE(SUBSTITUTE(MID(B1,FIND("<",B1)+1,LEN(B1)-FIND("<",B1)-1),"(at)","#"),"(dot)",".")
Give this a try:
Sub splitter()
Dim r As Range, v As String
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
v = r.Text
If v <> "" Then
ary = Split(v, " <")
r.Offset(0, 1).Value = ary(0)
r.Offset(0, 2).Value = Replace(Replace(Replace(ary(1), ">", ""), "(at)", "#"), "(dot)", ".")
End If
Next r
End Sub
This sub uses columns C and D for the output. Modify the code to suite your needs.
To extract the name, try =TRIM(LEFT(B1,FIND("<",B1)-1)). user3005775's answer works for the email.
You can also do this easily a regular expression (you'll need to add a reference to Microsoft VBScript Regular Expressions):
Private Sub ExtractEmailInfo(value As String)
Dim expr As New RegExp
Dim result As Object
Dim user As String
Dim addr As String
expr.Pattern = "(.+)(<.+>)"
Set result = expr.Execute(value)
If result.Count > 0 Then
user = result(0).SubMatches(0)
addr = result(0).SubMatches(1)
'Strip the < and >
addr = Mid$(addr, 2, Len(addr) - 2)
addr = Replace$(addr, "(at)", "#")
addr = Replace$(addr, "(dot)", ".")
End If
Debug.Print user
Debug.Print addr
End Sub
Replace the Debug.Print calls with whatever you need to do to place them in cells.
This does it for 200 K rows in less than 15 seconds:
Option Explicit
Sub extractPattern()
Dim ws As Worksheet, ur As Range, rng As Range, t As Double
Dim fr As Long, fc As Long, lr As Long, lc As Long
Set ws = Application.ThisWorkbook.Worksheets("Sheet1")
Set ur = ws.UsedRange
fr = 1
fc = 1
lr = ws.Cells(ur.Row + ur.Rows.Count + 1, fc).End(xlUp).Row
lc = ws.Cells(fr, ur.Column + ur.Columns.Count + 1).End(xlToLeft).Column
Set rng = ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc))
enableXL False
t = Timer
rng.TextToColumns Destination:=ws.Cells(fr, lc + 1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
Space:=True
With ws.Columns(lc + 3)
.Replace What:="(at)", Replacement:="#", LookAt:=xlPart
.Replace What:="(dot)", Replacement:=".", LookAt:=xlPart
.Replace What:="<", Replacement:=vbNullString, LookAt:=xlPart
.Replace What:=">", Replacement:=vbNullString, LookAt:=xlPart
End With
ws.Range(ws.Cells(fr, lc + 1), ws.Cells(fr, lc + 3)).EntireColumn.AutoFit
Debug.Print "Total rows: " & lr & ", Duration: " & Timer - t & " seconds"
enableXL 'Total rows: 200,000, Duration: 14.4296875 seconds
End Sub
Private Sub enableXL(Optional ByVal opt As Boolean = True)
Application.ScreenUpdating = opt
Application.EnableEvents = opt
Application.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
End Sub
It places the new data in the first unused column at the end (splits the names as well)
Looking for some help with my macro that loops through subfolders and brings back data from the workbooks that match my filename pattern, because the name changes each month.
It works seamlessly if the pattern is "[0-9][0-9][0-9][0-9][0-9][0-9] Filename"
But fails if "[0-9][0-9][0-9][0-9]_[0-9][0-9] Filename"
Any ideas on how to handle the underscore please?
This fails "[0-9][0-9][0-9][0-9][_][0-9][0-9] Filename"
Thanks heaps
GWS
Option Explicit
Option Base 1
Private Const PORTFOLIO_CODE As String = "G030"
Private Sub ExtractData()
' get workbook list
Dim wbList As Collection
Set wbList = New Collection
Application.DisplayAlerts = False
RecursiveFileSearch _
"O:\Sales and Marketing\Monthly Reports\", _
"[0-9][0-9][0-9][0-9][_][0-9][0-9] Monthly Report.xlsm", _ 'fails to find any workbooks
'"[0-9][0-9][0-9][0-9][0-9][0-9] Monthly Report.xlsm", _ 'would work except my file names contain underscores
wbList
Dim resultOffset As Integer
wsResult.Name = result
resultOffset = 1
Dim wbName As Variant, wbOpen As Workbook, wsFund As Worksheet
For Each wbName In wbList
' loop through workbook list
' - open workbook, hidden
Application.ScreenUpdating = False
Set wbOpen = Workbooks.Open(Filename:=wbName, ReadOnly:=True)
wbOpen.Windows(1).Visible = False
' - get worksheet for fund
Set wsFund = wbOpen.Worksheets(PORTFOLIO_CODE)
Application.ScreenUpdating = True
' - find top of data
Dim valueDate As Date
valueDate = WorksheetFunction.EoMonth(DateSerial(2000 + CInt(Left(wbOpen.Name, 2)), CInt(Mid(wbOpen.Name, 3, 2)), 1), 0)
Debug.Print valueDate, wbOpen.Name
ThisWorkbook.Worksheets(PORTFOLIO_CODE).Activate
Dim baseData As Excel.Range
Set baseData = wsFund.Range("AQ:AQ").Find("Currency")
If Not baseData Is Nothing Then
' - loop through data
Dim rowOffset As Integer
rowOffset = 0
wsResult.Range("A1").Offset(resultOffset, 0).Value = valueDate ' baseData.Offset(rowOffset, 0).Value
wsResult.Range("A1").Offset(resultOffset, 1).Value = baseData.Offset(rowOffset, 0).Value
wsResult.Range("A1").Offset(resultOffset, 2).Value = baseData.Offset(rowOffset, 5).Value
resultOffset = resultOffset + 1
End If
' - close workbook
wbOpen.Close SaveChanges:=False
DoEvents
Next
Application.DisplayAlerts = True
End Sub
RecursiveFileSearch
Sub RecursiveFileSearch( _
ByVal targetFolder As String, _
ByRef filePattern As String, _
ByRef matchedFiles As Collection _
)
Dim oRegExp As New VBScript_RegExp_55.RegExp
oRegExp.Global = False
oRegExp.IgnoreCase = True
oRegExp.MultiLine = False
oRegExp.Pattern = filePattern
Dim oFSO As Scripting.FileSystemObject
Set oFSO = New Scripting.FileSystemObject
'Get the folder oect associated with the target directory
Dim oFolder As Variant
Set oFolder = oFSO.GetFolder(targetFolder)
'Loop through the files current folder
Dim oFile As Variant
For Each oFile In oFolder.Files
If oRegExp.test(oFile.Name) Then
matchedFiles.Add oFile
End If
Next
'Loop through the each of the sub folders recursively
Dim oSubFolders As Object
Set oSubFolders = oFolder.Subfolders
Dim oSubfolder As Variant
For Each oSubfolder In oSubFolders
RecursiveFileSearch oSubfolder, filePattern, matchedFiles
Next
'Garbage Collection
Set oFolder = Nothing
Set oFile = Nothing
Set oSubFolders = Nothing
Set oSubfolder = Nothing
Set oFSO = Nothing
Set oRegExp = Nothing
End Sub
Perhaps:
\d{4}_\d{2}.*Monthly Report\.xlsm
My code was escaping the () and . to override the defined regex behavior. Portland Runner suggestion solved the question. ^[0-9]{3,4}[_][0-9]{2} SAMPSON International Shares Passive (Hedged) Trust Mandate Monthly Report.xlsm
I'm creating an application that will be able to tell me who is logged onto what PC, in the manufacturing center, where I work.
I'm using psexec's psloggedon cmd process to get me the information for me and a VB.net windows application to show me the information.
I begin by first querying a databse for all the PC's we currently have active and dumping the data into a datagridview object. (Shown below)
Private Sub Button(sender As System.Object, e As System.EventArgs) Handles btngetPC.Click
'GET AREAS FROM DATABASE
Dim ds As New DataSet()
Dim db As String = "QUERY STRING GOES HERE"
'CONNECT TO DATABASE
Using da As New SqlDataAdapter(db, MySQLConnection)
da.Fill(ds, "MACHINE_NAME")
End Using
With datagridView1
.DataSource = ds.Tables("MACHINE_NAME")
End With
'ADD COLUMN TO DATAGRIDVIEW
datagridView1.Columns.Add("LOGGED_IN", "LOGGED_IN")
MySQLConnection.Close()
End Sub
Once I have my datagridview object filled out with all my active PC's, I can then use the machine names to run the psloggedon cmd to get who is logged in. I do so by using:
Private Sub execute(sender As Object, e As EventArgs) Handles bntExecuteCmd.Click
'COUNT ENTRIES
Dim RowCount As Integer = datagridView1.RowCount
''EXECUTE CMD
For i = 0 To RowCount - 2
'PERFORM PSLOGGEDON ROUTINE
Dim Proc1 As New Process
Proc1.StartInfo = New ProcessStartInfo("psloggedon")
Proc1.StartInfo.Arguments = "-l \\" & datagridView1.Rows(i).Cells(1).Value & ""
Proc1.StartInfo.RedirectStandardOutput = True
Proc1.StartInfo.UseShellExecute = False
Proc1.StartInfo.CreateNoWindow = True
Proc1.Start()
If Not Proc1.WaitForExit(300) Then
Proc1.Kill()
End If
'INSERT RESULTS INTO LOGGEN_IN COLUMN
Dim msg As String = Proc1.StandardOutput.ReadToEnd
Dim idx As Integer = msg.LastIndexOf("\"c)
Dim user As String = msg.Substring(idx + 1)
Dim final As String = UCase(System.Text.RegularExpressions.Regex.Replace(user, "^ELP.*$", ""))
datagridView1.Rows(i).Cells(2).Value = final
Next
End Sub
Finally, here is my question:
To get the employee names I must use regex becuase the raw format is unacceptable.
raw format:
"Connecting to Registry of \ELPSC171698...
Users logged on locally:
ECHOSTAR\Jane.Doe"
format after applying:
'INSERT RESULTS INTO LOGGEN_IN COLUMN
Dim msg As String = Proc1.StandardOutput.ReadToEnd
Dim idx As Integer = msg.LastIndexOf("\"c)
Dim user As String = msg.Substring(idx + 1)
Dim final As String = UCase(System.Text.RegularExpressions.Regex.Replace(user, "^ELP.*$", ""))
datagridView1.Rows(i).Cells(2).Value = final
"PAULA.RODRIGUEZ"
Looks good, right? However, when the raw format has more than one associate, like so:
"Connecting to Registry of \ELPSC173068...
Users logged on locally:
ECHOSTAR\John.Doe
ECHOSTAR\Ben.Doe"
the code I have written will get me the last person in this list. In this case, I will get JOHN.DOE when I need to get BEN.DOE.
Now the question: How can I change this code:
'INSERT RESULTS INTO LOGGEN_IN COLUMN
Dim msg As String = Proc1.StandardOutput.ReadToEnd
Dim idx As Integer = msg.LastIndexOf("\"c)
Dim user As String = msg.Substring(idx + 1)
Dim final As String = UCase(System.Text.RegularExpressions.Regex.Replace(user, "^ELP.*$", ""))
datagridView1.Rows(i).Cells(2).Value = final
To get me the first person, "JOHN.DOE" from here:
"Connecting to Registry of \ELPSC173068...
Users logged on locally:
ECHOSTAR\John.Doe
ECHOSTAR\Ben.Doe"
I hope my question was clear and well constructed. Thank you.
Use more specific regex and a capture group to get multiple items.
Dim mc As MatchCollection = Regex.Matches("Users logged on locally: ECHOSTAR\John.Doe ECHOSTAR\Ben.Doe", "[\t ]+[a-z_0-9]+\\(?<n>[a-z_\.0-9]+)(([\t ])|($))", RegexOptions.ExplicitCapture Or RegexOptions.IgnoreCase Or RegexOptions.Multiline)
For Each m As Match In mc
Dim name As String = m.Groups("n").value
Next
if you just want the first one then...
If mc.Count >= 1 Then
Dim name As String = mc(0).Groups("n").Value
End If
Change
Dim idx As Integer = msg.LastIndexOf("\"c)
to
Dim idx As Integer = msg.IndexOf("\"c)
Alternatively consider this:
Assuming you've validated the string first.
Dim user As String = msg.Split({"\"c, " "c}, StringSplitOptions.RemoveEmptyEntries)(1) _
.Replace("."c, " "c).ToUpper
To leave the decimal in just remove .Replace("."c, " "c)