Find string in cell and delete row for Multiple Workbooks

[gqdesi]

Hi All,
I am not too familiar with VBA and have compiled code from various sources to try and find a specified string (in my case "Author", "Owner" and "Page") and delete those rows, for multiple workbooks. My code is able to open all the files however it is not performing the delete function. Any help is much appreciated.

Thank you,
Jay

Sub Test1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String
Dim varList As Variant
Dim lngCounter As Long

Application.ScreenUpdating = False


MyPath = "C:\Users\Desktop\Excel"

FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop


If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0

If Not mybook Is Nothing Then
On Error Resume Next
varList = VBA.Array("Owner:", "Author:", "Page")
For lngCounter = LBound(varList) To UBound(varList)
With Sheet1.Range("A:A")
Set rngFound = .Find( _
What:=varList(lngCounter), _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False _
)


If Not rngFound Is Nothing Then
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If

strFirstAddress = rngFound.Address
Set rngFound = .FindNext(After:=rngFound)

Do Until rngFound.Address = strFirstAddress
Set rngToDelete = Application.Union(rngToDelete, rngFound)
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngCounter
If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
End If
mybook.Close savechanges:=True

Next FNum
End If

End Sub

 

[JLGWhiz]

I tried to fix it, but I did not test it completely. So it could very well through an error, especially in the find next area. But it should now be able to get the files, open them and build a Union range to delete.

Sub Test2()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String
Dim varList As Variant
Dim lngCounter As Long
Application.ScreenUpdating = False
MyPath = "C:\Users\Desktop\Excel"
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
        FilesInPath = Dir(MyPath & "*.xl*")
        FNum = 0
            Do While FilesInPath <> ""
                FNum = FNum + 1
                ReDim Preserve MyFiles(1 To FNum)
                MyFiles(FNum) = FilesInPath
                FilesInPath = Dir()
            Loop
        If FNum > 0 Then
            For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
                varList = VBA.Array("Owner:", "Author:", "Page")
                    For lngCounter = LBound(varList) To UBound(varList)
                        With Sheet1.Range("A:A")
                            Set rngFound = .Find( _
                            What:=varList(lngCounter), _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                                If Not rngFound Is Nothing Then
                                    strFirstAddress = rngFound.Address
                                        Do Until rngFound.Address = strFirstAddress
                                            If rngToDelete Is Nothing Then
                                                Set rngToDelete = rngFound
                                            Else
                                                Set rngToDelete = Application.Union(rngToDelete, rngFound)
                                            End If
                                            rngFound.Value = varList(lngCounter)
                                            Set rngFound = .FindNext(rngFound)
                                        Loop
                                End If
                        End With
                    Next lngCounter
                If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
            End If
            mybook.Close savechanges:=True
        Next FNum
    End If
End Sub

 

[gqdesi]

Thank you. The files are opening successfully, but it is not deleting the rows where it finds the string. I tried stepping through the macro and I don't think it is recognizing the search criteria. When I strip out the function to search multiple workbooks and place the macro directly into the excel file, it seems to be working. I'm not sure if this because the macro is being placed in PERSONAL.xls

 

[JLGWhiz]

I did test the code down to the FindNext funtion and it worked on my system, XP win7 xl2007, OK. I know it was building the Union range if the FindNext part worked, but I did not test it all the way through. At a quick glance, I don't see anything that would prohibit it from running in PERSONAL.xls file. It looks to me like all variables and ranges are well qualified with workbook and sheet references, and that would be the thing that would hiccup with the Personal file. I also tested to make sure that it would not balk at the EntireRow parameter being used with a union of non-contiguous cells, like it does with copy, but it executed the delete. I think that if you could be sure the FindNext function executes to build the complete Union range, it should work.