[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 528
  • Last Modified:

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 SummaryTestData.xlsx MSEx2007-Summary.xls SummaryTestData.xlsx
0
Steph_M
Asked:
Steph_M
  • 3
1 Solution
 
Robberbaron (robr)Commented:
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
 
Steph_MAuthor Commented:
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
 
NorieCommented:
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
 
Steph_MAuthor Commented:
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
 
Steph_MAuthor Commented:
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

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now