combining multiple find/replace subs

[Mark]

Hello

I have about 7 or 8 subs for finding and replacing after a huge amount
of .txt files have been searched for "href." They are meant for
extracting the data that I actually need. The only thing is, is that
the report I created with them in there takes way too long, almost an
hour. Is there a way to combine these or somehow speed up their
processing speed? Here are a couple examples, they are searching
through about 45,000 rows.

Sub DeleteRowsImg()

Dim r As Long
'Dim ans As String
Dim c As Range
Dim lrow As Long

'ans = InputBox("What string do you want rows to be deleted if they
contain it?")
Application.ScreenUpdating = False

lrow = ActiveSheet.UsedRange.Row - 1 + _
ActiveSheet.UsedRange.Rows.Count
For r = lrow To 1 Step -1
With Cells(r, 2)
Set c = .Find("img", LookIn:=xlValues)
If Not c Is Nothing Then
.EntireRow.Delete
End If
End With
Next r
Application.ScreenUpdating = True

End Sub

Sub DeleteRowsAboutus()

Dim r As Long
'Dim ans As String
Dim c As Range
Dim lrow As Long

'ans = InputBox("What string do you want rows to be deleted if they
contain it?")
Application.ScreenUpdating = False

lrow = ActiveSheet.UsedRange.Row - 1 + _
ActiveSheet.UsedRange.Rows.Count
For r = lrow To 1 Step -1
With Cells(r, 2)
Set c = .Find("aboutus", LookIn:=xlValues)
If Not c Is Nothing Then
.EntireRow.Delete
End If
End With
Next r
Application.ScreenUpdating = True

End Sub

 

[Rick Rothstein \(MVP - VB\)]

Maybe you are getting killed by all the recalculations taking place during
the deletes. Try putting...

Application.Calculation = xlCalculationManual

at the start of your code and...

Application.Calculation = xlCalculationAutomatic

at the end of your code and see if that helps any.

Rick

 

[Mark]

Maybe you are getting killed by all the recalculations taking place during
the deletes. Try putting...

     Application.Calculation = xlCalculationManual

at the start of your code and...

     Application.Calculation = xlCalculationAutomatic

at the end of your code and see if that helps any.

Rick

















- Show quoted text -

Thanks Richard, but that doesn't seem to really speed the process up
at all. It is still taking quite a while. Any other suggestions?

Thanks!
Mark

 

[Ron Rosenfeld]

I have about 7 or 8 subs for finding and replacing after a huge amount
of .txt files have been searched for "href." They are meant for
extracting the data that I actually need. The only thing is, is that
the report I created with them in there takes way too long, almost an
hour. Is there a way to combine these or somehow speed up their
processing speed? Here are a couple examples, they are searching
through about 45,000 rows.

If I understand what you're doing, perhaps a different method using built-in
VBA functions:


=============================
For r = lrow To 1 Step -1
With Cells(r, 2)
If InStr(1, .Value, "img") > 0 Then .EntireRow.Delete
End With
Next r
========================
--ron

 

[acbservices]

You can speed up the program by doing the deletes all at once instead
of row by row. Here is how I would do it. This can be done using
instr, autofilter, copy/paste, and deleting columns. This ran for me
in 5 seconds on 45,000 rows. This code assumes that all of your txt
data is in column A. Hope I understood correctly what you are looking
for. Best of luck, PB

Public Sub FindDelete()

Dim x As Long
Dim strCheck As String

Application.ScreenUpdating = False

'Autofilter Header
Rows("1").Insert
Cells(1, 1) = "Autofilter"

'Check
strCheck = "href" 'change for your needs

For x = 2 To fLastRow
If InStr(1, Cells(x, 1), strCheck, 1) = 0 Then
Cells(x, 2) = "X" 'Mark cells
End If
Next x

'Autofilter
Columns("A:B").AutoFilter Field:=2, Criteria1:="=" 'Filter
unmarked cells
Columns("A:A").Copy
Columns("C:C").Select
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

'Delete Autofilter Header
Rows("1").Delete

Application.ScreenUpdating = True

Cells(1, 1).Select

End Sub

Public Function fLastRow() As Double
'from http://www.ozgrid.com/VBA/ExcelRanges.htm

fLastRow = 0

If WorksheetFunction.CountA(Cells) > 0 Then
'Search for any entry, by searching backwards by Rows.
fLastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If

End Function

 

[Rick Rothstein \(MVP - VB\)]

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. The only things you need to
attend to are at the beginning of the code. There is a section with the
comment "Set your search conditions here" where you can set the worksheet,
first row of data to search, and the search column. Also, you need to add
all the words you are searching for, set up in a comma delimited string
(with NO "extra" spaces to pretty things up) in the Split function's first
argument in the section with the comment "Put your search strings in the
comma delimited string". That's it... Run the code and it should delete all
the appropriate rows and, hopefully, it will do it somewhat quicker than the
method you are now using.

Rick

***************** START OF CODE *****************
Sub ConditionalDelete()
Dim X As Long
Dim Z As Long
Dim LastRow As Long
Dim FoundRowToDelete As Boolean
Dim OriginalCalculationMode As Long
Dim RowsToDelete As Range
Dim SearchItems() As String

Dim DataStartRow As Long
Dim SearchColumn As String
Dim SheetName As String

' Set your search conditions here
DataStartRow = 1
SearchColumn = "B"
SheetName = "Sheet1"

' Put your search strings in the comma delimited string
SearchItems = Split("img,aboutus,othertext,etc", ",")

On Error GoTo Whoops
OriginalCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

With Worksheets(SheetName)
LastRow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row
For X = LastRow To DataStartRow Step -1
FoundRowToDelete = False
For Z = 0 To UBound(SearchItems)
If InStr(.Cells(X, SearchColumn).Value, SearchItems(Z)) Then
FoundRowToDelete = True
Exit For
End If
Next
If FoundRowToDelete Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Cells(X, SearchColumn)
Else
Set RowsToDelete = Union(RowsToDelete, .Cells(X, SearchColumn))
End If
If RowsToDelete.Areas.Count > 100 Then
RowsToDelete.EntireRow.Delete
Set RowsToDelete = Nothing
End If
End If
Next
End With
If Not RowsToDelete Is Nothing Then
RowsToDelete.EntireRow.Delete
End If

Whoops:
Application.Calculation = OriginalCalculationMode
Application.ScreenUpdating = True
End Sub
***************** END OF CODE *****************

Maybe you are getting killed by all the recalculations taking place during
the deletes. Try putting...

Application.Calculation = xlCalculationManual

at the start of your code and...

Application.Calculation = xlCalculationAutomatic

at the end of your code and see if that helps any.

Rick

















- Show quoted text -

Thanks Richard, but that doesn't seem to really speed the process up
at all. It is still taking quite a while. Any other suggestions?

Thanks!
Mark

 

[Mark]

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. The only things you need to
attend to are at the beginning of the code. There is a section with the
comment "Set your search conditions here" where you can set the worksheet,
first row of data to search, and the search column. Also, you need to add
all the words you are searching for, set up in a comma delimited string
(with NO "extra" spaces to pretty things up) in the Split function's first
argument in the section with the comment "Put your search strings in the
comma delimited string". That's it... Run the code and it should delete all
the appropriate rows and, hopefully, it will do it somewhat quicker than the
method you are now using.

Rick

***************** START OF CODE *****************
Sub ConditionalDelete()
  Dim X As Long
  Dim Z As Long
  Dim LastRow As Long
  Dim FoundRowToDelete As Boolean
  Dim OriginalCalculationMode As Long
  Dim RowsToDelete As Range
  Dim SearchItems() As String

  Dim DataStartRow As Long
  Dim SearchColumn As String
  Dim SheetName As String

  '  Set your search conditions here
  DataStartRow = 1
  SearchColumn = "B"
  SheetName = "Sheet1"

  '  Put your search strings in the comma delimited string
  SearchItems = Split("img,aboutus,othertext,etc", ",")

  On Error GoTo Whoops
  OriginalCalculationMode = Application.Calculation
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False

  With Worksheets(SheetName)
    LastRow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row
    For X = LastRow To DataStartRow Step -1
      FoundRowToDelete = False
      For Z = 0 To UBound(SearchItems)
        If InStr(.Cells(X, SearchColumn).Value, SearchItems(Z)) Then
          FoundRowToDelete = True
          Exit For
        End If
      Next
      If FoundRowToDelete Then
        If RowsToDelete Is Nothing Then
          Set RowsToDelete = .Cells(X, SearchColumn)
        Else
          Set RowsToDelete = Union(RowsToDelete, .Cells(X, SearchColumn))
        End If
        If RowsToDelete.Areas.Count > 100 Then
          RowsToDelete.EntireRow.Delete
          Set RowsToDelete = Nothing
        End If
      End If
    Next
  End With
  If Not RowsToDelete Is Nothing Then
    RowsToDelete.EntireRow.Delete
  End If

Whoops:
  Application.Calculation = OriginalCalculationMode
  Application.ScreenUpdating = True
End Sub
***************** END OF CODE *****************









Thanks Richard, but that doesn't seem to really speed the process up
at all.  It is still taking quite a while.  Any other suggestions?

Thanks!
Mark- Hide quoted text -

- Show quoted text -

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!

 

[Rick Rothstein \(MVP - VB\)]

Below my signature is a subroutine which proved to be quite

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

 

[Mark]

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