macro to distribute one text file among many - strange behaviour

[Jon Macmichael]

Hopefully your about Bernie as you well know the macro below. I'd
tested it a number of times on my Win2000 machine and it works
perfectly.

However, I have some how put a spanner in the works. Now that I have
my full databases, the updating has to be done on my other machine.
The only difference I made to the code was change the directory from
C:\ to E:\ in the string MyPath. And the strangest of strange is
happening; the last loop within the Application.FileSearch is running
its 'sequence' twice.

In Brief: The macro updates from rows in a single file to many
individual files based on a 3 letter code in each row of the single
update file. Where there is no update, the the last loop within
Application.FileSearch runs out a record to the file with a zero value
(ie each dates maintains a record). This is where the problem seems to
be occuring.

I ran a Debug.Print befre "With Application.FileSeach ..." on both
machines. The results were identical; the printouts both showed the
same list of files not requiring the appending of 'zero record' in the
oncoming loop.

For i = 1 to myFileCount
Debug.Print myDone(i)
Next i

Here's the code copied from the newer, faster WinXP machine with files
in E:\

Sub AppendFiles3()
Dim SourceNum As Integer
Dim DestNum As Integer
Dim Temp As String
Dim myDone() As String
Dim myFileCount As Integer
Dim i As Integer
Dim j As Integer
Dim FileDone As Boolean

Dim myPath As String
Dim myFile As String
Dim myOut As String
Dim myLabel As String
Dim myDest As String
Dim myDate As String

myPath = "E:\JMdata\tvASXCopy\"
myDest = "E:\JMdata\tvCopy\"

ChDrive myPath
ChDir myPath
myFile = Application.GetOpenFilename("Text Files (*.txt),*.txt,")
myLabel = Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute(myFile,
myPath, ""), ".txt", "")

'Jon, this line shouldn't be needed - myDate is the same as myLabel
when I run it
'But, it doesn't seem to hurt.... Try putting a break on this line and
reading the value
'of myLabel and myDate during execution

myDate = Mid(myLabel, InStr(17, myLabel, "\") + 1, 6)
myFileCount = 0

' Open the source text file.
SourceNum = FreeFile()
Open myFile For Input As SourceNum

' Read each line of the source file and append it to the destination
file.
Do While Not EOF(SourceNum)
Line Input #SourceNum, Temp
DestNum = FreeFile()

myOut = myDest & Left(Temp, InStr(1, Temp, ",") - 1) & "tv.txt"
Application.StatusBar = "Now processing " & myOut

'Keep a record of files done
myFileCount = myFileCount + 1
ReDim Preserve myDone(1 To myFileCount)
myDone(myFileCount) = myOut

Open myOut For Append As DestNum
Print #DestNum, myDate & " " & _
Mid(Temp, InStr(1, Temp, ",") + 1, Len(Temp))
Close #DestNum
Loop

' Close the source file.
Close #SourceNum

' The Debug.Print loop was here.

Application.StatusBar = False

With Application.FileSearch
.NewSearch
.LookIn = myDest
.FileType = msoFileTypeAllFiles
.SearchSubFolders = False
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
FileDone = False
'Check to see if the file was done
For j = 1 To UBound(myDone)
If .FoundFiles(i) = myDone(j) Then
FileDone = True
Exit For
End If
Next j
If Not FileDone Then
Open .FoundFiles(i) For Append As DestNum
Print #DestNum, myDate & " 0"
Close #DestNum
End If
Next i
End If
End With
MsgBox "Finished processing!"
End Sub

While this runs perfectly on one machine it is buggy on the other, So
guess showing the code above maynot be of any use. Any ideas on where
to look would be much appreciated.
Thanks
Jon

 

[Dave Peterson]

I'm not Bernie, but there have been quite a few posts that say
application.filesearch can be flakey with xl2002. Are you running xl2002 on the
problem pc.

I've seen it return the wrong number of files, but never run the loop twice.
And which loop did you mean? You had two (i and j):

For i = 1 To .FoundFiles.Count
FileDone = False
'Check to see if the file was done
For j = 1 To UBound(myDone)
If .FoundFiles(i) = myDone(j) Then
FileDone = True
Exit For
End If
Next j
If Not FileDone Then
Open .FoundFiles(i) For Append As DestNum
Print #DestNum, myDate & " 0"
Close #DestNum
End If
Next i

Maybe using the Dir() function would be less flakey--I didn't set up a test
environment, but the following did compile!

Option Explicit
Sub AppendFiles3A()
Dim SourceNum As Integer
Dim destNum As Integer
Dim Temp As String
Dim myDone() As String
Dim myFileCount As Integer
Dim i As Integer
Dim j As Integer
Dim fileDone As Boolean

Dim myPath As String
Dim myFile As String
Dim myOut As String
Dim myLabel As String
Dim myDest As String
Dim myDate As String

Dim fCtr As Long
Dim myInFiles() As String
Dim myInFile As String

myPath = "E:\JMdata\tvASXCopy\"
myDest = "E:\JMdata\tvCopy\"

'ChDrive myPath
'ChDir myPath
myFile = Application.GetOpenFilename("Text Files (*.txt),*.txt,")
myLabel = Application.WorksheetFunction.Substitute _
(Application.WorksheetFunction.Substitute _
(myFile, myPath, ""), ".txt", "")

'Jon, this line shouldn't be needed - myDate is the same as myLabel when
'I run it
'But, it doesn't seem to hurt.... Try putting a break on this line and
'reading the value
'of myLabel and myDate during execution

myDate = Mid(myLabel, InStr(17, myLabel, "\") + 1, 6)
myFileCount = 0

' Open the source text file.
SourceNum = FreeFile()
Open myFile For Input As SourceNum

' Read each line of the source file and append it to the destination file.
Do While Not EOF(SourceNum)
Line Input #SourceNum, Temp
destNum = FreeFile()

'myOut = myDest & Left(Temp, InStr(1, Temp, ",") - 1) & "tv.txt"
Application.StatusBar = "Now processing " & myOut

'Keep a record of files done
myFileCount = myFileCount + 1
ReDim Preserve myDone(1 To myFileCount)
myDone(myFileCount) = myOut

Open myOut For Append As destNum
Print #destNum, myDate & " " & _
Mid(Temp, InStr(1, Temp, ",") + 1, Len(Temp))
Close #destNum
Loop

' Close the source file.
Close #SourceNum

' The Debug.Print loop was here.

Application.StatusBar = False

myInFile = Dir(myDest & "*.*")
If myInFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myInFile <> ""
fCtr = fCtr + 1
ReDim Preserve myInFiles(1 To fCtr)
myInFiles(fCtr) = myDest & myInFile
myInFile = Dir()
Loop

If fCtr > 0 Then
For i = 1 To fCtr
fileDone = False
'Check to see if the file was done
For j = 1 To UBound(myDone)
If myInFiles(i) = myDone(j) Then
fileDone = True
Exit For
End If
Next j
If Not fileDone Then
Open myInFiles(i) For Append As destNum
Print #destNum, myDate & " 0"
Close #destNum
End If
Next i
End If

MsgBox "Finished processing!"
End Sub

 

[Jon Macmichael]

Apologies. My fault. Found my problem.

It was uppercase/lowercase issue with a string printed in the ReDim
Preserve statement not matching that returned by the
Application.FileSearch

My first encounter.
Sorry
Jon