Question : VBA Code needs converted from MS Excel 2003 to 2007

Hello Experts,

The Excel Workbook that I use to consolidate multiple workbooks into one for reporting has stopped working because some of the 2003 Excel methods are not available in MS Excel 2007. The code reads through any workbook in a given directory and pulls the data out of the specified cell.

I originally thought the problem was due to macro security or trusted paths but eliminate that by testing it in 2003 - it worked fine there.

Can one of you please rewrite the code below to work in MS Excel 2007? The one method that I know does not work for sure is FIleSearch.

I've recreated sample files for test purposes:
File MSEx2007 has the code that should that should load the data from Summary TestData.

Sub copyFromFiles()
    Dim wksCopyTo As Worksheet
    Dim wkbCopyFrom As Workbook
    Dim copyToHere As Range
   
    Set wksCopyTo = ThisWorkbook.Sheets(1)
    wksCopyTo.Cells.Clear
   
   
    Set copyToHere = wksCopyTo.Range("a1")
    n = 0
   
    On Error Resume Next
   
    Application.FileSearch.LookIn = ThisWorkbook.Path
    Application.FileSearch.FileType = msoFileTypeExcelWorkbooks
    Application.FileSearch.SearchSubFolders = False
    Application.FileSearch.Execute
   
    For i = 1 To Application.FileSearch.FoundFiles.Count
        If Application.FileSearch.FoundFiles(i) = ThisWorkbook.FullName Then GoTo NotMe

    Set wkbCopyFrom = Workbooks.Open(Application.FileSearch.FoundFiles(i))
    n = n + 1
    With wkbCopyFrom.Sheets("Sheet1")
        copyToHere.Offset(0, 1) = .Range("D4").Value 'Project Name
        copyToHere.Offset(0, 2) = .Range("D5").Value 'Requested By
   
       
    End With
   
    'With wkbCopyFrom.Sheets("Sheet2")
        'copyToHere.Offset(0, 6) = .Range("J7").Value
    'End With
                 
    With wkbCopyFrom.Sheets("Sheet3l")
   
        copyToHere.Offset(0, 30) = .Range("C60").Value


    End With
       
    Set copyToHere = copyToHere.Offset(1)
   
    wkbCopyFrom.Close False
   
NotMe:
    Next i
       
       
End Sub


Thank you for taking a look at this.

Steph M.
 
 
MSEx2007-Summary.xls (44 KB) (File Type Details) 
Worksheet with VBA Code
 
 
SummaryTestData.xlsx (8 KB) (File Type Details) 
Worksheet that contains data for extraction
 
 
MSEx2007-Summary.xls (44 KB) (File Type Details) 
Worksheet with VBA Code
 
 
SummaryTestData.xlsx (8 KB) (File Type Details) 
Worksheet that contains data for extraction
 

Answer : VBA Code needs converted from MS Excel 2003 to 2007

i have moved the code to a module, which is the more common place to find it.

and then added a Class that mimics most of the Application.FileSearch.
it is mostly the work of others but i fixed it to search subfolders better and impement more functions of the original fileseach.

I uploaded the revised workbook but otherwise....

>%<---------'your revised code.... place into a module and delete the old from Workbook1

Sub copyFromFiles()
   Dim wksCopyTo As Worksheet
   Dim wkbCopyFrom As Workbook
   Dim copyToHere As Range
   
   Set wksCopyTo = ThisWorkbook.Sheets(1)
   wksCopyTo.Cells.Clear
   
   
   Set copyToHere = wksCopyTo.Range("a1")
   n = 0
   
   On Error Resume Next
   Dim AppFileSearch As New FileSearch
   
   AppFileSearch.LookIn = ThisWorkbook.path
   AppFileSearch.fileType = "xls?"            '<<<will only do one extension, or use xls*, xls?
   AppFileSearch.fileName = "SummarytestData"   '<<<<For testing
   AppFileSearch.SearchSubFolders = True
   AppFileSearch.Execute
   
   For i = 1 To AppFileSearch.Count
       If AppFileSearch.FoundFiles(i) = ThisWorkbook.FullName Then
           'skip this one '
           'GoTo NotMe
       Else
            Set wkbCopyFrom = Workbooks.Open(AppFileSearch.FoundFiles(i))
            n = n + 1
            With wkbCopyFrom.Sheets("Sheet1")
                copyToHere.Offset(0, 1) = .Range("A1").value
                copyToHere.Offset(0, 2) = .Range("B1").value
                copyToHere.Offset(0, 3) = .Range("C1").value
                copyToHere.Offset(0, 4) = .Range("A4").value
                copyToHere.Offset(0, 5) = .Range("B4").value
                copyToHere.Offset(0, 6) = .Range("C4").value
             End With
           
            Set copyToHere = copyToHere.Offset(1)
   
           wkbCopyFrom.Close False
       End If

   Next i
     
       
End Sub


>%<---------------------
place this code into a new ClassModule and name it  FileSearch

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:

''by PrismP @ http://social.msdn.microsoft.com/Forums/en-US/isvvba/thread/a450830d-4fc3-4f4e-aee2-03f7994369d6
'http://social.msdn.microsoft.com/profile/prizmp/?type=forum&referrer=http://social.msdn.microsoft.com/Forums/en-US/isvvba/thread/a450830d-4fc3-4f4e-aee2-03f7994369d6


Dim pLookIn As String
Dim pSearchSubFolders As Boolean
Dim pFileName As String
Dim pFileType As String

Public pFoundFiles As New Collection


Private Sub Class_Initialize()
    pLookIn = "."
    pFileType = "*"
    pFileName = "*"
    pSearchSubFolders = False
    
End Sub
Public Function NewSearch()
    Class_Initialize
    Set pFoundFiles = New Collection
    
End Function
Public Property Get Count() As String
    Count = pFoundFiles.Count
End Property
Public Property Get FoundFiles(xx) As String
    FoundFiles = pFoundFiles(xx)
End Property
Public Property Get LookIn() As String
    LookIn = pLookIn
End Property
Public Property Let LookIn(value As String)
    pLookIn = value
End Property
Public Property Get SearchSubFolders() As Boolean
    SearchSubFolders = pSearchSubFolders
End Property
Public Property Let SearchSubFolders(value As Boolean)
    pSearchSubFolders = value
End Property
Public Property Get fileName() As String
    fileName = pFileName
End Property
Public Property Let fileName(value As String)
    pFileName = value
End Property
Public Property Get fileType() As String
    fileType = pFileType
End Property
Public Property Let fileType(value As String)
    pFileType = value
End Property
Public Function Execute() As Long

    Dim i As Long
    Dim sLookIn As String
    Dim sDirName As String
    Dim sCurDir As String
    Dim sFileName As String
    'Dim ff As FilesFound
   
    i = 1
    'Set ff = New FileSearchFound
    sLookIn = pLookIn
    RecurseFolder (sLookIn)
    
    
    
    Execute = pFoundFiles.Count
End Function

Sub RecurseFolder(sFolderStart)
    
    sFileName = Dir(sFolderStart & "\" & pFileName & "." & pFileType, vbNormal)
    Do Until Len(sFileName) = 0

        pFoundFiles.Add (sFolderStart & "\" & sFileName)
        sFileName = Dir
    Loop
    If pSearchSubFolders Then
        sDirName = Dir(sFolderStart & "\", vbDirectory)
        Dim FoundDirectories As New Collection, xxDir As Variant
        Do Until Len(sDirName) = 0
        
            sCurDir = sFolderStart & "\" & sDirName
            If GetAttr(sCurDir) = vbDirectory And sDirName <> "." And sDirName <> ".." Then
                FoundDirectories.Add sCurDir
            End If
            sDirName = Dir
        Loop
        For Each xxDir In FoundDirectories
            RecurseFolder (xxDir)
        Next xxDir
 
    End If


End Sub
Public Function Clear() As Long
    NewSearch
End Function
 
MSEx2007-Summary.xls (59 KB)  (File Type Details) 
Updated macro workbook
 
Random Solutions  
 
programming4us programming4us