Why won't this code run??
 

I'm trying to loop thru all workbooks in a folder and copy the left 6 digits
of the file name from A1 to the last row with data. When I run the code it
stops on the first workbook and does nothing???

Here's the code:

Option Explicit
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Sub PrepFiles()
Dim basebook As Workbook
Dim mybook As Workbook
Dim facility As Long
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Lr As Long

SaveDriveDir = CurDir

MyPath = "E:\Ron Hoffman\Inpatient\Test\2003 Credit Balances"
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

On Error GoTo CleanUp

Application.ScreenUpdating = False
Application.EnableEvents = False

Do While FNames < ""
Set mybook = Workbooks.Open(FNames, UpdateLinks:=0)
facility = Left(mybook, 6)
Lr = LastRow(Sheets("Credit Detail"))
Sheets("Credit Detail").Range("A1:A" & Lr).Value = facility

mybook.Close True
FNames = Dir()
Loop

CleanUp:
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Why won't this code run??
 

There will be a problem if your find function does not find anything. When
that happens the function returns empty, which your long variable Lr converts
to a zero. On the next line you refernce A1:A0 which is an invalid range...
That is one issue that needs to be fixed...

Lr = LastRow(Sheets("Credit Detail"))
Sheets("Credit Detail").Range("A1:A" & Lr).Value = facility

HTH

"TEB2" wrote:

I'm trying to loop thru all workbooks in a folder and copy the left 6 digits
of the file name from A1 to the last row with data. When I run the code it
stops on the first workbook and does nothing???

Here's the code:

Option Explicit
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Sub PrepFiles()
Dim basebook As Workbook
Dim mybook As Workbook
Dim facility As Long
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Lr As Long

SaveDriveDir = CurDir

MyPath = "E:\Ron Hoffman\Inpatient\Test\2003 Credit Balances"
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

On Error GoTo CleanUp

Application.ScreenUpdating = False
Application.EnableEvents = False

Do While FNames < ""
Set mybook = Workbooks.Open(FNames, UpdateLinks:=0)
facility = Left(mybook, 6)
Lr = LastRow(Sheets("Credit Detail"))
Sheets("Credit Detail").Range("A1:A" & Lr).Value = facility

mybook.Close True
FNames = Dir()
Loop

CleanUp:
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub