Where to insert code?
Whoops! That should be:
It still stops in the middle of the file!
Sub FastAcNos()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim AcNo As String
Dim eAc As Long
Dim i As Long
Dim sh As Long
Dim fndAc As Range
Dim tbox As TextBox
On Error GoTo Errorhandler
Application.ScreenUpdating = False
eAc = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("c:\Documents and Settings" & _
"\zzfy98\My Documents\Test") 'change directory
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open Filename:=objFolder.Path _
& "\" & objFile.Name, UpdateLinks:=False
With Workbooks(objFile.Name)
For sh = 1 To .Sheets.Count
bDone = True
For i = 1 To eAc
If LCase(ThisWorkbook.Sheets("Sheet1") _
.Cells(i, 2).Value) < "yes" Then
' All accounts not found
bDone = False
AcNo = ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value
With .Sheets(sh).Cells
Set fndAc = .Find(AcNo _
, LookIn:=xlValues _
, Lookat:=xlPart _
, MatchCase:=True)
End With
If Not fndAc Is Nothing Then
ThisWorkbook.Sheets("Sheet1"). _
Cells(i, 2).Value = "Yes"
Else
' Tom's Code:
For Each tbox In .Sheets(sh).TextBoxes
If InStr(1, AcNo, tbox.Text, vbTextCompare) Then
' AcNo found
ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value = "Yes" ' I
assume???
End If
Next tbox
End If
End If
Next i
If bDone Then
.Close False
Exit Sub
End If
Next sh
.Close False
Set objFile = Nothing
End With
End If
Next
For i = 1 To eAc
With ThisWorkbook.Sheets("sheet1")
If IsEmpty(.Cells(i, 2)) Then
.Cells(i, 2).Value = "No"
End If
End With
Next
Errorhandler:
Application.ScreenUpdating = True
Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
End Sub
|