Processing xls files sequentially

**Bjornago** · 06-18-2009, 08:16 PM

Gday all,

I use Excel 2003 at work, and 2007 at home. The wife is crook today, so im working from home... well, trying to. I have searched the net for a solution to my particular prob, but while I am ok with developing and running some macro's, im not really a power user.

Problem:
I understand that Application.FileSearch has been depreciated in 2007, but I cannot seem to modify other suggested codes to make workarounds work with my needs. Im hoping someone here can help

I have a folder with a many .xls files in it, all ending in "*metrics33yrs.xls", my 2003 code (sourced from the net) opens each one sequentially (1st part of below code), copies given cells, and pastes them into a separate workbook (2nd part of below code).

Can anyone please help with the first part of the code so that it works in 2007?

Cheers in advance

 '---------------------------------------------------------------------------------------------------------

Sub RunAllFiles_AllMetrics()

Dim lCount As Long, wbResults As Workbook, wbCodeBook As Workbook

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Application.EnableEvents = False

On Error Resume Next

Set wbCodeBook = ThisWorkbook

    With Application.FileSearch

        .NewSearch

         'Change path to suit

        .LookIn = "E:\Work\Work\MetricResults_010908"

        .FileType = msoFileTypeExcelWorkbooks

        .Filename = "*Metrics33*.xls"

            If .Execute > 0 Then 'Workbooks in folder

                For lCount = 1 To .FoundFiles.Count 'Loop through all.

                 'Open Workbook x and Set a Workbook variable to it

                 Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)


 '---------------------------------------------------------------------------------------------------------


thisname = ActiveWorkbook.Name
sitename = Split(thisname, "_")
shname = sitename(0) & "_Totems33yrs"
Sheets(shname).Activate

...selects and copies cells...

Windows("AllMetrics_EMLR+WMLR.xls").Activate
    Select Case lCount
    Case 0 To 10
        asheet = "Sheet1"
    Case 11 To 20
        asheet = "Sheet2"
    Case 21 To 30
        asheet = "Sheet3"
    Case 31 To 40
        asheet = "Sheet4"
    Case 41 To 50
        asheet = "Sheet5"
    Case 51 To 60
        asheet = "Sheet6"
    Case 61 To 70
        asheet = "Sheet7"
    Case 71 To 80
        asheet = "Sheet8"
    Case 81 To 90
        asheet = "Sheet9"
    Case 91 To 100
        asheet = "Sheet10"
    Case 101 To 110
        asheet = "Sheet11"
    Case 111 To 120
        asheet = "Sheet12"
    
    End Select
    Sheets(asheet).Activate
    Range("a1").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate

    ActiveSheet.Paste

**shg** · 06-18-2009, 08:33 PM

Welcome to the forum, Bjornago.

Please take a few minutes to read the forum rules, and then edit your post to add code tags.

**shg** · 06-18-2009, 09:16 PM

Thanks.

FileSearch isn't deprecated in 2007, it's gone. Puzzling.

This isn't fully cooked yet, but let me know how you get on.

Function FindFilesUDF(sPatt As String, sDir As String) As Variant
    ' shg 2009-06
    
    Dim nDir    As Long
    Dim nFile   As Long
    Dim sFiles  As String
    
    FindFilesUDF = FindFileRec(sDir, sPatt, nDir, nFile)
    If Len(FindFilesUDF) Then
        FindFilesUDF = Split(Left(FindFilesUDF, Len(FindFilesUDF) - 1), vbLf)
    Else
        FindFilesUDF = Empty
    End If
End Function

Private Function FindFileRec(ByVal sDir As String, sPatt As String, _
                             nDir As Long, nFile As Long, _
                             Optional bStatusBar As Boolean = False) As String
    ' shg 2009-06
    
    Const iAttr As Long = vbNormal Or vbHidden Or vbSystem Or vbReadOnly

    Dim tFld    As Folder
    Dim tFil    As File
    Dim sFile   As String

    On Error GoTo Oops
    Set oFld = oFSO.GetFolder(sDir)

    Application.StatusBar = "Searching " & sDir & " ..."
    sFile = Dir(sDir & "\", iAttr)

    Do While Len(sFile)
        If LCase(sFile) Like sPatt Then
            nFile = nFile + 1
            FindFileRec = FindFileRec & sDir & "\" & sFile & vbLf
        End If
        sFile = Dir()
        DoEvents
    Loop

    nDir = nDir + 1
    If oFld.SubFolders.Count Then
        For Each tFld In oFld.SubFolders
            FindFileRec = FindFileRec + FindFileRec(tFld.Path, sPatt, nDir, nFile)
            DoEvents
        Next
    End If
    Exit Function

Oops:
    sFile = ""
    Resume Next
End Function

It REQUIRES a reference to Microsoft Scripting Runtime.

FindFilesLike("*Metrics33*.xls", "E:\Work\Work\MetricResults_010908")

will return a variant that is either Empty or contains a list of found files.

**Bjornago** · 06-18-2009, 09:22 PM

I have just found a code by RoyUK which seems to fit the bill...

However... when i run the code, and it reaches the Do While sFil <> "", it skips straight to the end loop. I have stipulated the right directory, and have changed the file format (sFil = Dir("*.xlsx")) to .xls to match the 2003 files i have, so am at a loss why this isn't working...

Private Sub CommandButton1_Click()
' Module : Module1
' DateTime : 09/05/2007 08:43
' Author : Roy Cox (royUK)' Website : www.excel-it.com for more examples and Excel Consulting
' Purpose : Open all worksheets in a specific folder' Disclaimer; This code is offered as is with no guarantees. You may use it in your' projects but please leave this header intact.
'---------------------------------------------------------------------------------------
Dim oWbk As Workbook
Dim sFil As String
Dim sPath As String

sPath = "C:\Documents and Settings\klahvic\Desktop\Monthly Reports" 'location of files
ChDir sPath
sFil = Dir("*.xlsx") 'change or add formats
Do While sFil <> "" 'will start LOOP until all files in folder sPath have been looped through Set
oWbk = Workbooks.Open(sPath & "\" & sFil) 'opens the file
' do something
oWbk.Close True 'close the workbook, saving changes
sFil = Dir
Loop ' End of LOOP
End Sub

**Bjornago** · 06-18-2009, 09:56 PM

Cheers shg, muchly appreciate your time and effort, but using functions is out of my league, haven't mucked around with them before...

I've referenced the scripting runtime, but am unsure how to use your code from there...

**shg** · 06-19-2009, 06:25 PM

Like this:

Option Explicit

Sub RunAllFiles_AllMetrics()
    Dim vFiles  As Variant
    Dim i       As Long
    Dim wkbRslt As Workbook
    Dim wkbCode As Workbook

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    Set wkbCode = ThisWorkbook

    vFiles = FindFilesLike("*Metrics33*.xls", "E:\Work\Work\MetricResults_010908")
    If vFiles = Empty Then Exit Sub

    For i = LBound(vFiles) To UBound(vFiles)
        Set wkbRslt = Workbooks.Open(Filename:=vFiles(i), UpdateLinks:=False)
        ' carry on from here