Object doesn't support this action

[neiltharvey]

Hi all. This is my first thread, and hope someone can help me. I know this question has been posted before, and I've tried to follow the solutions, but just get very confused! I'm quite a novice to Excel, and have taken on a spreadsheet that produces MI reports for a customer, and I've just upgraded to 2007, and find that the Application. Filesearch isn't supported. After a bit of hunting (told you I'm a novice), I found the code:

'Capture Directory name and file type
With Application.FileSearch
.NewSearch
.LookIn = txtDirectory
.SearchSubFolders = True
.FileName = txtFileName
.Execute
TotalFiles = .FoundFiles.count
If (TotalFiles > MAX_FILES) Then
MsgBox "Max number of files exceded. Max is " + CStr(MAX_FILES)
GoTo Exit_Get_Data
End If
count = 1
Do While count < TotalFiles + 1
CurrentFile = .FoundFiles(count)
'Remove path (for stats ONLY)
FileLength = Len(CurrentFile)
FileLoc = InStrRev(CurrentFile, "\")
FileNameOnly = Right(CurrentFile, FileLength - FileLoc)

FilesList = FilesList & FileNameOnly & Chr(10)
'find where to paste
Sheets(REPORT_WORKSHEET).Select
R = 1
Do While Cells(R, 1) > ""
R = R + 1
Loop
StartAddress = "A" & R

With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & CurrentFile, Destination:=Range(StartAddress))
.Name = CurrentFile
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = ","
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
count = count + 1
Loop
End With

Can some clever person somewhere out there tell me in idiot terms what I need to change in the above code to get it to work? Many thanks in anticapation, Neil Harvey

 

[xld]

Untested

Dim txtdirectory As String
Dim TotalFiles As Long
Dim FoundFiles As Variant

    txtdirectory = "C:\Documents and Settings\xld\My Documents\data\spreadsheets"
    Call GetFiles(txtdirectory, TotalFiles, FoundFiles)
    
    Count = 1
    Do While Count <= TotalFiles
        CurrentFile = FoundFiles(Count)
        'Remove path (for stats ONLY)
        FileLength = Len(CurrentFile)
        FileLoc = InStrRev(CurrentFile, "\")
        FileNameOnly = Right(CurrentFile, FileLength - FileLoc)

        FilesList = FilesList & FileNameOnly & Chr(10)
        'find where to paste
        Sheets(REPORT_WORKSHEET).Select
        R = 1
        Do While Cells(R, 1) > ""
            R = R + 1
        Loop
        StartAddress = "A" & R

        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & CurrentFile, Destination:=Range(StartAddress))

            .Name = CurrentFile
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileOtherDelimiter = ","
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With

        Count = Count + 1
    Loop
End Sub

Private Sub GetFiles(StartDir As String, Count As Long, DataArray As Variant)
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FilesystemObject")
    ReDim DataArray(1 To 1)
    Call ReadFolder(FSO, StartDir, Count, DataArray)
    Set FSO = Nothing
End Sub

Private Sub ReadFolder(FSO As Object, StartDir As String, Count As Long, DataArray As Variant)
Dim file As Object
Dim folder As Object
Dim subfolder As Object

    Set folder = FSO.getfolder(StartDir)
    For Each file In folder.Files
    
        Count = Count + 1
        ReDim Preserve DataArray(1 To Count)
        DataArray(Count) = file.Path
    Next file
    
    For Each subfolder In folder.subFolders
    
        Call ReadFolder(FSO, subfolder.Path, Count, DataArray)
    Next subfolder
End Sub

 

[neiltharvey]

Thank you, xld, you are a real genius!! After a little bit of tinkering, I've got it working perfectly, and it even gives the same results as the 2003 version!! Thanks again, and if I see you at Leeds Beer Festival next week, I'll buy you a pint!!

 

[xld]

Thank you, xld, you are a real genius!! After a little bit of tinkering, I've got it working perfectly, and it even gives the same results as the 2003 version!! Thanks again, and if I see you at Leeds Beer Festival next week, I'll buy you a pint!!

Highly unlikely that I will travel 271 miles up to dark and cold t'north for a pint of beer

 

[Richard Schollar]

Highly unlikely that I will travel 271 miles up to dark and cold t'north for a pint of beer

Now had that been a single malt he'd probably have made the effort!

 

[xld]

Now had that been a single malt he'd probably have made the effort!

I'm going up to the darklands of Scotland next month for that very reason