On Apr 22, 3:53*pm, "Rick Rothstein \(MVP - VB\)"
wrote:
Below my signature is a subroutine which proved to be quite
speedy from a past posting of mine, modified for what I think
your conditions are. Give it a try and let me know how it works
out for you.

Actually Rick, it works perfectly fine! *I was confused with the
With (SheetName) - I was putting the actual name of the sheet
in there forgetting it was already dimensioned as a variable.
Thanks so much!

You said your original code took nearly an hour... out of curiosity, how
long did the routine I posted take?

Rick

It was originally about exactly an hour, and now its about 15
minutes. That's a pretty substantial amount of processing time!

Hey would you mind looking at something else for me? I have code that
finds all .txt files within a folder and its subfolders. It finds
these .txt files, then searches through them for any reference of
"href" (the .txt files are web site source code). When it finds an
"href" is copies the entire line and puts into Excel. I don't need
all the stuff in the actual line so I have code to take what I need.
Essentially I am searching for all 3rd party sites. I am able to get
the URL of the page the 3rd party link is on in column A, and the URL
of the 3rd party link into column B. I am trying to get 2 more
things, the Title of the page, and the name of the 3rd party link on
the page. When I run the code, I get no errors but the columns don't
populate. Here is the code that I have, any suggestions would be
great! Thanks!

Mark

Sub CheckTextFilesForHREFs()

MsgBox "Press OK to begin report"
Dim WholeLine As String
Dim myPath As String
Dim workfile As String
Dim myR As Long

myPath = "C:\Exelon\"
workfile = Dir(myPath & "*.html")
'sLine = WholeLine

Set fs = Application.FileSearch
With fs
.LookIn = "C:\Exelon"
.Filename = ".html"
.SearchSubFolders = True
'.FileType = mosFileTypeAllFiles
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
ParseURL .FoundFiles(i)
ParseTitle .FoundFiles(i) 'these are the ones it won't
populate
ParseLink .FoundFiles(i) 'these are the ones it won't
populate
Next i

Else
MsgBox "There were no files found."
End If
End With

Sub ParseURL(strFile As String) 'THIS ONE WORKS FINE
Dim strTxt As String, lngTxt As Long, i As Long, oMatches
Dim ws As Worksheet, j As Long, k As Long, m As Long, oMatches2
Dim reg, oMatches3, reg2
i = FreeFile
'strFile = "c:\Users\Richard\Documents\Htmltest.html"
lngTxt = FileLen(strFile)
strTxt = Space(lngTxt)
Open strFile For Binary Access Read As #i
Get #i, , strTxt
Close #i
Debug.Print strTxt
With CreateObject("vbscript.regexp")
.Global = True
.ignorecase = True
.Pattern = vbCrLf & ".*?href.*?(?=" & vbCrLf & ")"
If .test(strTxt) Then
Set oMatches = .Execute(strTxt)
For i = 0 To oMatches.Count - 1
Set reg = CreateObject("vbscript.regexp")
With reg
.Global = True
.ignorecase = True
.Pattern = "href=\""(.*?)\"""
k = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Cells(k, 1).Value = strFile
If .test(oMatches(i)) Then
Set oMatches2 = .Execute(oMatches(i))
For j = 0 To oMatches2.Count - 1
Cells(k, j + 2) = .Replace(oMatches2(j),
"$1")
Next j
End If
End With
Next i
End If
End With
End Sub

Sub ParseLink(strFile As String)
Dim strTxt As String, lngTxt As Long, i As Long, oMatches
Dim ws As Worksheet, j As Long, k As Long, m As Long, oMatches2
Dim reg, oMatches3, reg2
i = FreeFile
'strFile = "c:\Users\Richard\Documents\Htmltest.html"
lngTxt = FileLen(strFile)
strTxt = Space(lngTxt)
Open strFile For Binary Access Read As #i
Get #i, , strTxt
Close #i
Debug.Print strTxt
With CreateObject("vbscript.regexp")
.Global = True
.ignorecase = True
.Pattern = vbCrLf & ".*?href.*?(?=" & vbCrLf & ")"
If .test(strTxt) Then
Set oMatches = .Execute(strTxt)
For i = 0 To oMatches.Count - 1
Set reg = CreateObject("vbscript.regexp")
With reg
.Global = True
.ignorecase = True
.Pattern = "<A \""(.*?)\""</A"
<------------------------------not sure if syntax is right here
k = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Cells(k, 1).Value = strFile
If .test(oMatches(i)) Then
Set oMatches2 = .Execute(oMatches(i))
For j = 0 To oMatches2.Count - 1
Cells(k, j + 4) = .Replace(oMatches2(j),
"$1")
Next j
End If
End With
Next i
End If
End With
End Sub