Run time error 1004 file not found

[Berni]

Hello all,

I copied and modified the code below to extract data from a Excel
workbook we are using as a form to a target file that becomes a
worklist. People fill out the Excel workbook form and save the file
as a number. At the end of the week, I run the macro and it extracts
the data from all of the saved files into one sheet. The run time
error appears to occur at the first file that has a longer length.
For example:

123456.xls
123456.xls
123456789.xls (gets stuck here)

I've tried troubleshooting and researching the runtime error topics
without success. The only thing that has work is if I open the first
file with the longer length and save it with the same name, the macro
will run without problems.

Thanks in advance.

Berni


Dim wsd As Worksheet 'target file
Dim wbc As Workbook 'source file
Dim IRowDst As Long
Dim szFileCur As String
Dim szDir As String

Call Template ' opens the destination template

ChDir ("U:\Data\Patient Financial Services\CKHS\PTFINSVC\Patient
Refund Requests\")

Const cszDir As String = "U:\Data\Patient Financial Services\CKHS
\PTFINSVC\Patient Refund Requests\"

Set wsd = ActiveSheet
IRowDst = Cells(Rows.Count, "A").End(xlUp).Row + 1
szFileCur = Dir(cszDir & "*.xls")

Do While szFileCur <> ""
Set wbc = Workbooks.Open(szFileCur)

Application.EnableEvents = False
'get data here
wsd.Cells(IRowDst, 1) = wbc.Worksheets(1).Range("IU5")
'Facility
wsd.Cells(IRowDst, 2) = wbc.Worksheets(1).Range("IU8")
'Account Type
wsd.Cells(IRowDst, 3) = wbc.Worksheets(1).Range("B10") 'DOS
wsd.Cells(IRowDst, 4) = wbc.Worksheets(1).Range("B12")
'Patient full name
wsd.Cells(IRowDst, 5) = wbc.Worksheets(1).Range("B15") 'Pat
No
wsd.Cells(IRowDst, 6) = wbc.Worksheets(1).Range("IU17")
'Payee First Name (no punc)
wsd.Cells(IRowDst, 7) = wbc.Worksheets(1).Range("IV17")
'Payee Last Name
wsd.Cells(IRowDst, 8) = wbc.Worksheets(1).Range("IU20") 'Pat
Addr1
wsd.Cells(IRowDst, 9) = wbc.Worksheets(1).Range("IU22") 'Pat
Addr2
wsd.Cells(IRowDst, 10) = wbc.Worksheets(1).Range("IU24") 'City/
State
wsd.Cells(IRowDst, 11) = wbc.Worksheets(1).Range("B26") 'Zip
Code
wsd.Cells(IRowDst, 12) = wbc.Worksheets(1).Range("IU30") 'Expln
Refund
wsd.Cells(IRowDst, 13) = wbc.Worksheets(1).Range("B32")
'Expln2
wsd.Cells(IRowDst, 14) = wbc.Worksheets(1).Range("B36")
'Refund Amt
wsd.Cells(IRowDst, 15) = wbc.Worksheets(1).Range("B40")
'Requestor
wsd.Cells(IRowDst, 16) = wbc.Worksheets(1).Range("F40") 'Date

wbc.Close False

szFileCur = Dir
IRowDst = IRowDst + 1
Loop
Application.EnableEvents = True
End Sub

 

[john]

Not got time to test but see if this approach helps you will note that I have
made a vain attempt to shorten the code.


Sub AAA()
Dim wsd As Worksheet 'target file
Dim wbc As Workbook 'source file
Dim IRowDst As Long
Dim szFileCur As String
Dim szDir As String
Dim myarray()
Dim na As Integer

Call Template ' opens the destination template

Const cszDir As String = "U:\Data\Patient Financial
Services\CKHS\PTFINSVC\Patient Refund Requests\"


myarray = Array("IU5", "IU8", "B10", "B12", "B15", _
"IU17", "IV17", "IU20", "IU22", "IU24", _
"B26", "IU30", "B32", "B36", "B40", "F40")


Set wsd = ActiveSheet

With wsd

IRowDst = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

End With

szFileCur = Dir(cszDir & "*.xls", vbNormal)

Application.EnableEvents = False

Do While szFileCur <> ""

Set wbc = Workbooks.Open(cszDir & szFileCur, ReadOnly:=True)

For na = 1 To 16
'get data here

wsd.Cells(IRowDst, na) = _
wbc.Worksheets(1).Range(myarray(na - 1))

Next na

wbc.Close False

Set wbc = Nothing

szFileCur = Dir

IRowDst = IRowDst + 1

Loop

Application.EnableEvents = True

End Sub

 

[Berni]

Not gottimeto test but see if this approach helps you will note that I have
made a vain attempt to shorten the code.

Sub AAA()
    Dim wsd As Worksheet    'target file
    Dim wbc As Workbook  'source file
    Dim IRowDst As Long
    Dim szFileCur As String
    Dim szDir As String
    Dim myarray()
    Dim na As Integer

    Call Template ' opens the destination template

    Const cszDir As String = "U:\Data\Patient Financial
Services\CKHS\PTFINSVC\Patient Refund Requests\"

    myarray = Array("IU5", "IU8", "B10", "B12", "B15", _
                    "IU17", "IV17", "IU20", "IU22", "IU24", _
                    "B26", "IU30", "B32", "B36", "B40", "F40")

    Set wsd = ActiveSheet

    With wsd

        IRowDst = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

    End With

    szFileCur = Dir(cszDir & "*.xls", vbNormal)

    Application.EnableEvents = False

    Do While szFileCur <> ""

        Set wbc = Workbooks.Open(cszDir & szFileCur, ReadOnly:=True)

         For na = 1 To 16
        'get data here

        wsd.Cells(IRowDst, na) = _
        wbc.Worksheets(1).Range(myarray(na - 1))

        Next na

        wbc.Close False

        Set wbc = Nothing

        szFileCur = Dir

        IRowDst = IRowDst + 1

    Loop

    Application.EnableEvents = True

End Sub

--
jb

















- Show quoted text -

Thanks John! Your code worked perfectly.