[RESOLVED] Excel VBA - Finding data in merged cells
Hi All,
I use the macro below to search multiple workbooks in a directory for specific data, it then returns the data showing the workbook name, worksheet name, cell address and then the data found in the cell. This works great, until it finds information I'm searching for which is in a merged cell (merged cells are unavoidable unfortunatley). It then throws up an error of 'Object variable or With block variable not set'. The spreadsheet that it has found the information in, is left open and even though it has thrown up the error and stopped the macro, it has returned all the correct data from the merged cell on the search results sheet. How do I have the macro continue it's routine, as it has found the data, it just doesn't continue to search other spreadsheets.
Any help would be appreciated.
Code:
Sub SearchFolders()
Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
strPath = Sheets("Sheet1").Range("B3").Value
strSearch = Sheets("Sheet1").Range("D3").Value
Set wOut = Worksheets.Add
lRow = 1
With wOut
.Cells(lRow, 1) = "Workbook"
.Cells(lRow, 2) = "Worksheet"
.Cells(lRow, 3) = "Cell"
.Cells(lRow, 4) = "Text in Cell"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
strFile = Dir(strPath & "\*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open _
(Filename:=strPath & "\" & strFile, _
UpdateLinks:=0, _
ReadOnly:=True, _
AddToMRU:=False)
For Each wks In wbk.Worksheets
Set rFound = wks.UsedRange.Find(strSearch)
If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If
Do
If rFound Is Nothing Then
Exit Do
Else
lRow = lRow + 1
.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value
End If
Set rFound = wks.Cells.FindNext(After:=rFound)
Loop While strFirstAddress <> rFound.Address
Next
wbk.Close (False)
strFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
MsgBox "Done"
ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Re: [RESOLVED] Excel VBA - Finding data in merged cells
Hello John757,
I made some changes to your macro. This should work without throwing any errors.
Code:
Sub SearchFolders()
Dim lRow As Long
Dim oFile As Object
Dim oFiles As Object
Dim oFolder As Object
Dim rFound As Range
Dim rSearch As Range
Dim strFirstAddress As String
Dim strSearch As String
Dim vPath As Variant
Dim wbk As Workbook
Dim wks As Worksheet
Dim wOut As Worksheet
Application.ScreenUpdating = False
vPath = ThisWorkbook.WorkSheets("Sheet1").Range("B3").Value
strSearch = Thisworkbook.WorkSheets("Sheet1").Range("D3").Value
With CreateObject("Shell.Application")
Set oFolder = .Namespace(vPath)
If oFolder Is Nothing Then
MsgBox "The folder """ & vPath & """ was Not Found.", vbExclamation
Exit Sub
End If
Set oFiles = oFolder.Items
' // Open only xls, xlsx, and xlsm workbooks
oFiles.Filter 64, "*.xls;*.xlsx;*.xlsm"
End With
Set wOut = Worksheets.Add
lRow = 1
' // Add row headers to the new worksheet.
wOut.Range("A1:D1").Value = Array("Workbook", "Worksheet", "Cell", "Text in Cell")
For Each oFile In oFiles
Set wbk = Workbooks.Open _
(FileName:=oFile.Path, _
UpdateLinks:=0, _
ReadOnly:=True, _
AddToMRU:=False)
For Each wks In wbk.Worksheets
Set rSearch = wks.UsedRange
Set rFound = rSearch.Find(strSearch)
If rFound Is Nothing Then Exit Sub
strFirstAddress = rFound.Address
Do
lRow = lRow + 1
wOut.Cells(lRow, "A").Resize(1, 4).Value = Array(wbk.Name, wks.Name, rFound.Address, rFound.Value)
Set rFound = wks.Cells.FindNext(rFound)
If rFound Is Nothing Then Exit Do
If rFound.Address = strFirstAddress Then Exit Do
Loop
Next wks
wOut.Columns("A:D").EntireColumn.AutoFit
wbk.Close SaveChanges:=False
Next oFile
MsgBox "Done"
Application.ScreenUpdating = True
End Sub
Re: [RESOLVED] Excel VBA - Finding data in merged cells
This should work without throwing any errors.
i am not sure he would be still waiting for an answer, though it might well help someone finding this thread from a search
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: [RESOLVED] Excel VBA - Finding data in merged cells
Hello to all,
the new modification works in part.
If it does not find anything, a workbook is opened.
Is a change possible?
After the search, a new sheet should not be created.
max
Re: [RESOLVED] Excel VBA - Finding data in merged cells
i would suggest you go back to the thread you started, for one reason this old thread is already marked resolved
Is a change possible?
of course it is, but i am not really sure, what you actually want to achieve, others may have a better idea, what do you want to do with the found results? are you actually wanting the search to be through multiple workbooks?
Last edited by westconn1; Apr 10th, 2018 at 04:38 PM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete