i have written a code and it works fine for some time and then it terminates without any warnings/errors. it also terminates after evaluating different number of records each time. the code is given below:
Option Explicit
Dim countworkbooks As Integer
Dim workbooklist(1 To 50000) As String
Dim r As Long
Private Sub CommandButton1_Click()
Dim FolderName As String
Dim SearchString As String
Dim j As Integer
Dim i As Integer
Dim loop1 As Long
Dim loop2 As Long
Dim str1 As String
Dim str2 As String
Dim x As Long
MsgBox ("started")
countworkbooks = 0
Range("A3").Formula = "File Path: "
Range("A3").Font.Bold = True
Range("B3").Formula = "Error: "
Range("B3").Font.Bold = True
FolderName = Range("A1").Formula
SearchString = Range("B1").Formula
r = Range("A65536").End(xlUp).row + 1
x = Sheets("Sheet1").Range("A65536").End(xlUp).row + 1
'Get list of all excel files in an array
ListFilesInFolder FolderName, True
'get total number of workbooks
'MsgBox ("total number of workbooks: " & countworkbooks)
'Sort array
For loop1 = 1 To countworkbooks
For loop2 = loop1 To countworkbooks
If UCase(workbooklist(loop2)) < UCase(workbooklist(loop1)) Then
str1 = workbooklist(loop1)
str2 = workbooklist(loop2)
workbooklist(loop1) = str2
workbooklist(loop2) = str1
End If
Next loop2
Next loop1
'printing the sorted array list
For i = 1 To countworkbooks
Sheets("Sheet1").Cells(x, 1).Formula = workbooklist(i)
x = x + 1
Next i
For j = 1 To countworkbooks
Sheets("Sheet2").Range("A2").Formula = Sheets("Sheet1").Cells(j + 1, 1).Formula
'Range("A2").Formula = workbooklist(j)
Call GetDataFromClosedWorkbook(Sheets("Sheet1").Cells(j + 1, 1).Formula, SearchString)
'Call GetDataFromClosedWorkbook(workbooklist(j), SearchString)
Next j
Columns("A:D").AutoFit
MsgBox ("finished")
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
'lists information about the files in SourceFolder
'example: ListFilesInFolder "C:\FolderName\", True
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim filetype As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
filetype = Right(FileItem.Name, 4)
If filetype = ".xls" Then
countworkbooks = countworkbooks + 1
workbooklist(countworkbooks) = FileItem.Path
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Private Function GetDataFromClosedWorkbook(FilePath As String, SearchString As String)
Dim wb As Workbook
Dim sheetcount As Integer
Dim rowcount As Integer
Dim columncount As Integer
Dim sheetname As String
Dim check As String
Dim check1 As Long
Dim workbookname As String
Dim celladdress As String
Application.ScreenUpdating = False 'turn off the screen updating
Application.EnableEvents = False
'Application.DisplayAlerts = False 'turn off display alerts
Set wb = Workbooks.Open(FilePath, False, True)
workbookname = wb.Name
'list of all the sheets in the workbook nad then go to each cell
For sheetcount = 1 To wb.Sheets.count
sheetname = wb.Sheets(sheetcount).Name
If WorksheetFunction.CountA(wb.Sheets(sheetname).Cells) <> 0 Then
'MsgBox ("enter worksheet" & sheetname)
For rowcount = 1 To wb.Sheets(sheetcount).Cells.Find(what:="*", SearchDirection:=xlPrevious, searchorder:=xlByRows).row
On Error Resume Next
For columncount = 1 To wb.Sheets(sheetcount).Cells.Find(what:="*", SearchDirection:=xlPrevious, searchorder:=xlByColumns).Column
On Error GoTo ErrHandler
check = wb.Sheets(sheetcount).Cells(rowcount, columncount).Formula
check1 = SF_count(LCase(check), LCase(SearchString))
If (check1 > 0) Then
GoTo ExitHere
'check = "'" & check & "'"
'celladdress = wb.Sheets(sheetcount).Cells(rowcount, columncount).Address
'Call appendToTable(FilePath, "NO")
End If
Next columncount
Next rowcount
End If
Next sheetcount
wb.Close False 'close without saving changes
Set wb = Nothing ' free memory
Application.ScreenUpdating = True 'turn on the screen updating
Exit Function
ExitHere:
Call appendToTable(FilePath, "NO")
wb.Close False 'close without saving changes
Set wb = Nothing ' free memory
Application.ScreenUpdating = True 'turn on the screen updating
Exit Function
ErrHandler:
Call appendToTable(FilePath, "YES")
Resume Label1
Label1:
'MsgBox ("label error")
wb.Close False 'close without saving changes
Set wb = Nothing ' free memory
'Application.DisplayAlerts = True 'turn on display alert
Application.EnableEvents = True
Application.ScreenUpdating = True 'turn on the screen updating
End Function
Function SF_count(ByVal Haystack As String, ByVal Needle As String) As Long
'count the number of occurences of needle in haystack
'SF_count(" This is my string ","i") returns 3
Dim i As Long, j As Long
If SF_isNothing(Needle) Then
SF_count = 0
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_count = 0
Else
i = 0
For j = 1 To Len(Haystack)
If Mid(Haystack, j, Len(Needle)) = Needle Then i = i + 1
Next j
SF_count = i
End If
End If
End Function
Function SF_isNothing(ByVal Haystack As String) As Boolean
'check if there is anything in a string (to avoid testing for
'isnull, isempty, and zero-length strings)
'SF_isNothing(" This is my string ") returns False
If Haystack & "" = "" Then
SF_isNothing = True
Else
SF_isNothing = False
End If
End Function
Private Sub appendToTable(workbookname As String, error As String)
Cells(r, 1).Formula = workbookname
Cells(r, 2).Formula = error
'Cells(r, 3).Formula = celladdress
'Cells(r, 4).Formula = cellvalue
r = r + 1
End Sub
Bookmarks