Solved: read from list and delete rows if cells contains expression from that list

[saban]

ub Read_text_File()

Dim oFSO As New FileSystemObject
Dim oFS
Dim luka As Range
Set oFS = oFSO.OpenTextFile("C:\list.txt")

Do Until oFS.AtEndOfStream
STEXT = oFS.ReadLine
R = ActiveSheet.UsedRange.Rows.Count

Range("A1").Select
For i = 1 To R
Set luka = Cells.Find(What:=STEXT, After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not luka Is Nothing Then
If STEXT = "" Then
GoTo znova
End If
luka.Select
Selection.Delete shift:=xlUp
ActiveCell.Offset(-1, 0).Select
'End If
Else
GoTo znova:
End If
Next i
znova:
'End If
Loop
R = ActiveSheet.UsedRange.Rows.Count

Range("A1").Select
'For i = 1 To R
On Error Resume Next ' In case there are no blanks
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' Next i

End Sub

I have a normal txt file which software names in each line
(actually not full software name but just partial name e.g : instead microsoft office I have just microsoft)

So when this keyword is found in excel row whole row should get deleted, so leaving no empty rows, but for some reason it doesnt work well, I found that a lot entries are deleted even if keyword is not in txt file)

thank you very much for your answers

[mdmackillop]

Untested but try

Option Explicit
Sub Read_text_File()
Dim oFSO As New FileSystemObject
Dim oFS
Dim luka As Range
Dim FirstAddress As String
Dim STEXT As String

Set oFS = oFSO.OpenTextFile("C:\list.txt")
Do Until oFS.AtEndOfStream
STEXT = oFS.ReadLine
With Worksheets(1).Cells
Set luka = Cells.Find(What:=STEXT, After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False)
If Not luka Is Nothing Then
FirstAddress = luka.Address
Do
luka.EntireRow.Delete
Set luka = .FindNext(luka)
Loop While Not luka Is Nothing And luka.Address <> FirstAddress
End If
End With
Loop
On Error Resume Next ' In case there are no blanks
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

[saban]

thnank you very much will let you know if it works

[saban]

I get an error
Set luka = .FindNext(luka)
"unable to get property find next..."
error 1004

Any ideas why

[mdmackillop]

Option Explicit
Sub Read_text_File()
Dim oFSO As New FileSystemObject
Dim oFS
Dim luka As Range, d As Range
Dim FirstAddress As String
Dim STEXT As String

Set oFS = oFSO.OpenTextFile("C:\list.txt")
Do Until oFS.AtEndOfStream
STEXT = oFS.ReadLine
With Worksheets(1).Cells
Set luka = Cells.Find(What:=STEXT, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False, SearchFormat:=False)
If Not luka Is Nothing Then
FirstAddress = luka.Address
Do
Set d = luka
On Error GoTo Exits
Set luka = .FindNext(luka)
d.EntireRow.Delete
Loop While Not luka Is Nothing
End If
End With
Exits:
On Error Resume Next ' In case there are no blanks
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

[saban]

Why this SearchDirection:=xlPrevious

Somehow it doesnt go through all the list

This throws an error and becaus eof on error resume next the macro finishes with deleting row
On Error Goto Exits
Set luka = .FindNext(luka)
d.EntireRow.Delete
Loop While Not luka Is Nothing
End If
End With
Exits:
On Error Resume Next ' In case there are no blanks
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

[saban]

the search is more like 10,000 rows than 10

[mdmackillop]

Can you post a small sample of the workbook and text file?

[saban]

I have did this like this
what do you think
Option Explicit
Sub Read_text_File()

Dim oFSO As New FileSystemObject
Dim oFS
Dim luka As Range, d As Range
Dim FirstAddress As String
Dim STEXT As String
Dim chosen
Dim name
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Choose your list of software you want to exclude from list"
.ButtonName = "Yes this is my list"
.Filters.Add "Documents", "*.txt"
.FilterIndex = 2
If .Show = -1 Then
chosen = Application.FileDialog(msoFileDialogFilePicker).SelectedItems.Item(1)
Else
Unload UserForm1
Exit Sub
End If
End With
Set oFS = oFSO.OpenTextFile(chosen)
Do Until oFS.AtEndOfStream
STEXT = oFS.ReadLine
'With Worksheets(1).Cells
' Set luka = Cells.Find(What:=STEXT, After:=ActiveCell, LookIn:=xlFormulas, _
' LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
' MatchCase:=False, SearchFormat:=False)
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
' .ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With ActiveSheet
'We select the sheet so we can change the window view
.Select
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed
.DisplayPageBreaks = False
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = Lastrow To Firstrow Step -1
'We check the values in the A column in this example
With .Cells(Lrow, "A")
If Not IsError(.Value) Then

Set luka = Cells.Find(What:=STEXT, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If luka Is Nothing Then GoTo naprej Else luka.Select
'This will delete each row with the Value "ron"
'in Column A, case sensitive.
'If luka = Then .EntireRow.Delete
End If
If STEXT = "" Then GoTo konec

'End If
Selection.EntireRow.Delete
End With
Next Lrow
naprej:
End With
' ActiveWindow.View = ViewMode
'With Application
' .ScreenUpdating = True
' .Calculation = CalcMode
'End With
Loop
konec:
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
MsgBox "Clean-up complete"
'On Error Resume Next ' In case there are no blanks

End Sub

[mdmackillop]

In this extract, you are carrying out a search of all cells once for each row in your range. You could be searching 100 times for 1 return. Using the FindNext method should loop the required numbers of times only.

For Lrow = Lastrow To Firstrow Step -1
'We check the values in the A column in this example
With .Cells(Lrow, "A")
If Not IsError(.Value) Then

Set luka = Cells.Find(What:=STEXT, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If luka Is Nothing Then GoTo naprej Else luka.Select
'This will delete each row with the Value "ron"
'in Column A, case sensitive.
'If luka = Then .EntireRow.Delete
End If
If STEXT = "" Then GoTo konec

'End If
Selection.EntireRow.Delete
End With
Next Lrow

[saban]

I see that way speed preformance would be way better than now but the results would be 100% identical

Am I thinking right??

Thanx again for all your help

[mdmackillop]

That's correct.

[saban]

thnx man I appreciate your help very much:beerchug: