Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

VBA Code needs converted from MS Excel 2003 to 2007

Posted on 2010-08-19
5
Medium Priority
?
526 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
5 Comments
 
LVL 32

Accepted Solution

by:
Robberbaron (robr) earned 2000 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
 
LVL 1

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 35

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
 
LVL 1

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
 
LVL 1

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

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This script will sweep a range of IP addresses (class c only, 255.255.255.0) and report to a log the version of office installed. What it does: 1.)      Creates log file in the directory the script is run from (if it doesn't already exist) 2.)      Sweep…
Over the years I have built up my own little library of code snippets that I refer to when programming or writing a script.  Many of these have come from the web or adaptations from snippets I find on the Web.  Periodically I add to them when I come…
This tutorial will teach you the special effect of super speed similar to the fictional character Wally West aka "The Flash" After Shake : http://www.videocopilot.net/presets/after_shake/ All lightning effects with instructions : http://www.mediaf…
In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…
Suggested Courses

610 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