Solved

VBA Code needs converted from MS Excel 2003 to 2007

Posted on 2010-08-19
5
479 Views
Last Modified: 2012-05-10
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 SummaryTestData.xlsx MSEx2007-Summary.xls SummaryTestData.xlsx
0
Comment
Question by:Steph_M
  • 3
5 Comments
 
LVL 32

Accepted Solution

by:
Robberbaron (robr) earned 500 total points
ID: 33483907
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


''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

Open in new window

MSEx2007-Summary.xls
0
 

Author Comment

by:Steph_M
ID: 33484269
Wow! That is way over my head! I'll load it into a module, which I've done before and let you know how it goes.  Thank you!
0
 
LVL 33

Expert Comment

by:Norie
ID: 33486187
FileSearch is the only thing in that code not available in 2007.

There are various ways of replacing it, one of which is the class method robberbarron posted.

That one is new to me, but I don't really do a lot of work with classes in VBA for this sort of thing.

You should give it a try, I'm going to.

Another idea would be to use the simple Dir command.
Sub copyFromFiles()

Dim wksCopyTo As Worksheet

Dim wkbCopyFrom As Workbook

Dim copyToHere As Range

Dim strFileName As String

Dim strPath As String



    Set wksCopyTo = ThisWorkbook.Sheets(1)



    wksCopyTo.Cells.Clear





    Set copyToHere = wksCopyTo.Range("a1")



    strPath = ThisWorkbook.Path



    strFileName = Dir(strPath & "\*.xls")



    While strFileName <> ""



        If strFileName <> ThisWorkbook.Name Then



            Set wkbCopyFrom = Workbooks.Open(strFileName)

            

            With wkbCopyFrom.Sheets(1)



                copyToHere.Offset(0, 1) = .Range("D4").Value    'Project Name

                copyToHere.Offset(0, 2) = .Range("D5").Value    'Requested By



            End With



            With wkbCopyFrom.Sheets(3)



                copyToHere.Offset(0, 30) = .Range("C60").Value



            End With



            Set copyToHere = copyToHere.Offset(1)



            wkbCopyFrom.Close False

        End If



        strFileName = Dir()



    Wend



End Sub

Open in new window

0
 

Author Comment

by:Steph_M
ID: 33486604
All:

I loaded robberbaron's code and when I compile it, it kicks out on the statement:

    Dim AppFileSearch As New FileSearch  with a error message of "Invalid use of NEW keyword.

However, when I run the code from the test workbook, in a different folder, it works perfectly. I originally thought it was due to me having a Module1 in my Personal.xls, but I deleted that module and I'm still getting the same error.

The only other thing I can think of is there are multiple modules with code for formatting functions - unfortunately, I can't take credit for the cool ones, they also came from expert's like. I attached a screen shot of one of them as an example.

I did try going through and commenting out any sub-routine with a DIM statement to see if that was the problem, but the debug still kicked out on that one line of code.

Any suggestions?

Stephanie
HvrScreenShot.docx
0
 

Author Closing Comment

by:Steph_M
ID: 33486772
Thanks Guys.

Robberbaron's code works just fine. Except I missed that part about naming it FileSearch and it kept bombing out. Fortunately, one of our programmers here at work figured it out in no time at all and showed me what I did wrong.

Saved again by the experts!

Stephanie
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Script to copy or move mouse-selected collection of files plus targets referenced by shortcuts (.lnk) The purpose of this article is to help illuminate the real challenges and options available (where they may exist) for utilizing simple scriptin…
Welcome back!  My apologies for taking so long to write part two of this series; it's been a long time coming!  As I promised in Part 1, this article will focus on how to locate those elusive AD properties that you are searching for.  Why is this us…
In this tutorial you'll learn about bandwidth monitoring with flows and packet sniffing with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're interested in additional methods for monitoring bandwidt…
This demo shows you how to set up the containerized NetScaler CPX with NetScaler Management and Analytics System in a non-routable Mesos/Marathon environment for use with Micro-Services applications.

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now